Theory Utils
section ‹Utilities›
theory Utils
imports Main Well_Quasi_Orders.Almost_Full_Relations
begin
lemma subset_imageE_inj:
assumes "B ⊆ f ` A"
obtains C where "C ⊆ A" and "B = f ` C" and "inj_on f C"
proof -
define g where "g = (λx. SOME a. a ∈ A ∧ f a = x)"
have "g b ∈ A ∧ f (g b) = b" if "b ∈ B" for b
proof -
from that assms have "b ∈ f ` A" ..
then obtain a where "a ∈ A" and "b = f a" ..
hence "a ∈ A ∧ f a = b" by simp
thus ?thesis unfolding g_def by (rule someI)
qed
hence 1: "⋀b. b ∈ B ⟹ g b ∈ A" and 2: "⋀b. b ∈ B ⟹ f (g b) = b" by simp_all
let ?C = "g ` B"
show ?thesis
proof
show "?C ⊆ A" by (auto intro: 1)
next
show "B = f ` ?C"
proof (rule set_eqI)
fix b
show "b ∈ B ⟷ b ∈ f ` ?C"
proof
assume "b ∈ B"
moreover from this have "f (g b) = b" by (rule 2)
ultimately show "b ∈ f ` ?C" by force
next
assume "b ∈ f ` ?C"
then obtain b' where "b' ∈ B" and "b = f (g b')" unfolding image_image ..
moreover from this(1) have "f (g b') = b'" by (rule 2)
ultimately show "b ∈ B" by simp
qed
qed
next
show "inj_on f ?C"
proof
fix x y
assume "x ∈ ?C"
then obtain bx where "bx ∈ B" and x: "x = g bx" ..
moreover from this(1) have "f (g bx) = bx" by (rule 2)
ultimately have *: "f x = bx" by simp
assume "y ∈ ?C"
then obtain "by" where "by ∈ B" and y: "y = g by" ..
moreover from this(1) have "f (g by) = by" by (rule 2)
ultimately have "f y = by" by simp
moreover assume "f x = f y"
ultimately have "bx = by" using * by simp
thus "x = y" by (simp only: x y)
qed
qed
qed
lemma wfP_chain:
assumes "¬(∃f. ∀i. r (f (Suc i)) (f i))"
shows "wfP r"
proof -
from assms wf_iff_no_infinite_down_chain[of "{(x, y). r x y}"] have "wf {(x, y). r x y}" by auto
thus "wfP r" unfolding wfP_def .
qed
lemma transp_sequence:
assumes "transp r" and "⋀i. r (seq (Suc i)) (seq i)" and "i < j"
shows "r (seq j) (seq i)"
proof -
have "⋀k. r (seq (i + Suc k)) (seq i)"
proof -
fix k::nat
show "r (seq (i + Suc k)) (seq i)"
proof (induct k)
case 0
from assms(2) have "r (seq (Suc i)) (seq i)" .
thus ?case by simp
next
case (Suc k)
note assms(1)
moreover from assms(2) have "r (seq (Suc (Suc i + k))) (seq (Suc (i + k)))" by simp
moreover have "r (seq (Suc (i + k))) (seq i)" using Suc.hyps by simp
ultimately have "r (seq (Suc (Suc i + k))) (seq i)" by (rule transpD)
thus ?case by simp
qed
qed
hence "r (seq (i + Suc(j - i - 1))) (seq i)" .
thus "r (seq j) (seq i)" using ‹i < j› by simp
qed
lemma almost_full_on_finite_subsetE:
assumes "reflp P" and "almost_full_on P S"
obtains T where "finite T" and "T ⊆ S" and "⋀s. s ∈ S ⟹ (∃t∈T. P t s)"
proof -
define crit where "crit = (λU s. s ∈ S ∧ (∀u∈U. ¬ P u s))"
have critD: "s ∉ U" if "crit U s" for U s
proof
assume "s ∈ U"
from ‹crit U s› have "∀u∈U. ¬ P u s" unfolding crit_def ..
from this ‹s ∈ U› have "¬ P s s" ..
moreover from assms(1) have "P s s" by (rule reflpD)
ultimately show False ..
qed
define "fun"
where "fun = (λU. (if (∃s. crit U s) then
insert (SOME s. crit U s) U
else
U
))"
define seq where "seq = rec_nat {} (λ_. fun)"
have seq_Suc: "seq (Suc i) = fun (seq i)" for i by (simp add: seq_def)
have seq_incr_Suc: "seq i ⊆ seq (Suc i)" for i by (auto simp add: seq_Suc fun_def)
have seq_incr: "i ≤ j ⟹ seq i ⊆ seq j" for i j
proof -
assume "i ≤ j"
hence "i = j ∨ i < j" by auto
thus "seq i ⊆ seq j"
proof
assume "i = j"
thus ?thesis by simp
next
assume "i < j"
with _ seq_incr_Suc show ?thesis by (rule transp_sequence, simp add: transp_def)
qed
qed
have sub: "seq i ⊆ S" for i
proof (induct i, simp add: seq_def, simp add: seq_Suc fun_def, rule)
fix i
assume "Ex (crit (seq i))"
hence "crit (seq i) (Eps (crit (seq i)))" by (rule someI_ex)
thus "Eps (crit (seq i)) ∈ S" by (simp add: crit_def)
qed
have "∃i. seq (Suc i) = seq i"
proof (rule ccontr, simp)
assume "∀i. seq (Suc i) ≠ seq i"
with seq_incr_Suc have "seq i ⊂ seq (Suc i)" for i by blast
define seq1 where "seq1 = (λn. (SOME s. s ∈ seq (Suc n) ∧ s ∉ seq n))"
have seq1: "seq1 n ∈ seq (Suc n) ∧ seq1 n ∉ seq n" for n unfolding seq1_def
proof (rule someI_ex)
from ‹seq n ⊂ seq (Suc n)› show "∃x. x ∈ seq (Suc n) ∧ x ∉ seq n" by blast
qed
have "seq1 i ∈ S" for i
proof
from seq1[of i] show "seq1 i ∈ seq (Suc i)" ..
qed (fact sub)
with assms(2) obtain a b where "a < b" and "P (seq1 a) (seq1 b)" by (rule almost_full_onD)
from ‹a < b› have "Suc a ≤ b" by simp
from seq1 have "seq1 a ∈ seq (Suc a)" ..
also from ‹Suc a ≤ b› have "... ⊆ seq b" by (rule seq_incr)
finally have "seq1 a ∈ seq b" .
from seq1 have "seq1 b ∈ seq (Suc b)" and "seq1 b ∉ seq b" by blast+
hence "crit (seq b) (seq1 b)" by (simp add: seq_Suc fun_def someI split: if_splits)
hence "∀u∈seq b. ¬ P u (seq1 b)" by (simp add: crit_def)
from this ‹seq1 a ∈ seq b› have "¬ P (seq1 a) (seq1 b)" ..
from this ‹P (seq1 a) (seq1 b)› show False ..
qed
then obtain i where "seq (Suc i) = seq i" ..
show ?thesis
proof
show "finite (seq i)" by (induct i, simp_all add: seq_def fun_def)
next
fix s
assume "s ∈ S"
let ?s = "Eps (crit (seq i))"
show "∃t∈seq i. P t s"
proof (rule ccontr, simp)
assume "∀t∈seq i. ¬ P t s"
with ‹s ∈ S› have "crit (seq i) s" by (simp only: crit_def)
hence "crit (seq i) ?s" and eq: "seq (Suc i) = insert ?s (seq i)"
by (auto simp add: seq_Suc fun_def intro: someI)
from this(1) have "?s ∉ seq i" by (rule critD)
hence "seq (Suc i) ≠ seq i" unfolding eq by blast
from this ‹seq (Suc i) = seq i› show False ..
qed
qed (fact sub)
qed
subsection ‹Lists›
lemma map_upt: "map (λi. f (xs ! i)) [0..<length xs] = map f xs"
by (auto intro: nth_equalityI)
lemma map_upt_zip:
assumes "length xs = length ys"
shows "map (λi. f (xs ! i) (ys ! i)) [0..<length ys] = map (λ(x, y). f x y) (zip xs ys)" (is "?l = ?r")
proof -
have len_l: "length ?l = length ys" by simp
from assms have len_r: "length ?r = length ys" by simp
show ?thesis
proof (simp only: list_eq_iff_nth_eq len_l len_r, rule, rule, intro allI impI)
fix i
assume "i < length ys"
hence "i < length ?l" and "i < length ?r" by (simp_all only: len_l len_r)
thus "map (λi. f (xs ! i) (ys ! i)) [0..<length ys] ! i = map (λ(x, y). f x y) (zip xs ys) ! i"
by simp
qed
qed
lemma distinct_sorted_wrt_irrefl:
assumes "irreflp rel" and "transp rel" and "sorted_wrt rel xs"
shows "distinct xs"
using assms(3)
proof (induct xs)
case Nil
show ?case by simp
next
case (Cons x xs)
from Cons(2) have "sorted_wrt rel xs" and *: "∀y∈set xs. rel x y"
by (simp_all)
from this(1) have "distinct xs" by (rule Cons(1))
show ?case
proof (simp add: ‹distinct xs›, rule)
assume "x ∈ set xs"
with * have "rel x x" ..
with assms(1) show False by (simp add: irreflp_def)
qed
qed
lemma distinct_sorted_wrt_imp_sorted_wrt_strict:
assumes "distinct xs" and "sorted_wrt rel xs"
shows "sorted_wrt (λx y. rel x y ∧ ¬ x = y) xs"
using assms
proof (induct xs)
case Nil
show ?case by simp
next
case step: (Cons x xs)
show ?case
proof (cases "xs")
case Nil
thus ?thesis by simp
next
case (Cons y zs)
from step(2) have "x ≠ y" and 1: "distinct (y # zs)" by (simp_all add: Cons)
from step(3) have "rel x y" and 2: "sorted_wrt rel (y # zs)" by (simp_all add: Cons)
from 1 2 have "sorted_wrt (λx y. rel x y ∧ x ≠ y) (y # zs)" by (rule step(1)[simplified Cons])
with ‹x ≠ y› ‹rel x y› show ?thesis using step.prems by (auto simp: Cons)
qed
qed
lemma sorted_wrt_distinct_set_unique:
assumes "antisymp rel"
assumes "sorted_wrt rel xs" "distinct xs" "sorted_wrt rel ys" "distinct ys" "set xs = set ys"
shows "xs = ys"
proof -
from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)
from assms(2-6) show ?thesis
proof(induct rule:list_induct2[OF 1])
case 1
show ?case by simp
next
case (2 x xs y ys)
from 2(4) have "x ∉ set xs" and "distinct xs" by simp_all
from 2(6) have "y ∉ set ys" and "distinct ys" by simp_all
have "x = y"
proof (rule ccontr)
assume "x ≠ y"
from 2(3) have "∀z∈set xs. rel x z" by (simp)
moreover from ‹x ≠ y› have "y ∈ set xs" using 2(7) by auto
ultimately have *: "rel x y" ..
from 2(5) have "∀z∈set ys. rel y z" by (simp)
moreover from ‹x ≠ y› have "x ∈ set ys" using 2(7) by auto
ultimately have "rel y x" ..
with assms(1) * have "x = y" by (rule antisympD)
with ‹x ≠ y› show False ..
qed
from 2(3) have "sorted_wrt rel xs" by (simp)
moreover note ‹distinct xs›
moreover from 2(5) have "sorted_wrt rel ys" by (simp)
moreover note ‹distinct ys›
moreover from 2(7) ‹x ∉ set xs› ‹y ∉ set ys› have "set xs = set ys" by (auto simp add: ‹x = y›)
ultimately have "xs = ys" by (rule 2(2))
with ‹x = y› show ?case by simp
qed
qed
lemma sorted_wrt_refl_nth_mono:
assumes "reflp P" and "sorted_wrt P xs" and "i ≤ j" and "j < length xs"
shows "P (xs ! i) (xs ! j)"
proof (cases "i < j")
case True
from assms(2) this assms(4) show ?thesis by (rule sorted_wrt_nth_less)
next
case False
with assms(3) have "i = j" by simp
from assms(1) show ?thesis unfolding ‹i = j› by (rule reflpD)
qed
fun merge_wrt :: "('a ⇒ 'a ⇒ bool) ⇒ 'a list ⇒ 'a list ⇒ 'a list" where
"merge_wrt _ xs [] = xs"|
"merge_wrt rel [] ys = ys"|
"merge_wrt rel (x # xs) (y # ys) =
(if x = y then
y # (merge_wrt rel xs ys)
else if rel x y then
x # (merge_wrt rel xs (y # ys))
else
y # (merge_wrt rel (x # xs) ys)
)"
lemma set_merge_wrt: "set (merge_wrt rel xs ys) = set xs ∪ set ys"
proof (induct rel xs ys rule: merge_wrt.induct)
case (1 rel xs)
show ?case by simp
next
case (2 rel y ys)
show ?case by simp
next
case (3 rel x xs y ys)
show ?case
proof (cases "x = y")
case True
thus ?thesis by (simp add: 3(1))
next
case False
show ?thesis
proof (cases "rel x y")
case True
with ‹x ≠ y› show ?thesis by (simp add: 3(2) insert_commute)
next
case False
with ‹x ≠ y› show ?thesis by (simp add: 3(3))
qed
qed
qed
lemma sorted_merge_wrt:
assumes "transp rel" and "⋀x y. x ≠ y ⟹ rel x y ∨ rel y x"
and "sorted_wrt rel xs" and "sorted_wrt rel ys"
shows "sorted_wrt rel (merge_wrt rel xs ys)"
using assms
proof (induct rel xs ys rule: merge_wrt.induct)
case (1 rel xs)
from 1(3) show ?case by simp
next
case (2 rel y ys)
from 2(4) show ?case by simp
next
case (3 rel x xs y ys)
show ?case
proof (cases "x = y")
case True
show ?thesis
proof (auto simp add: True)
fix z
assume "z ∈ set (merge_wrt rel xs ys)"
hence "z ∈ set xs ∪ set ys" by (simp only: set_merge_wrt)
thus "rel y z"
proof
assume "z ∈ set xs"
with 3(6) show ?thesis by (simp add: True)
next
assume "z ∈ set ys"
with 3(7) show ?thesis by (simp)
qed
next
note True 3(4, 5)
moreover from 3(6) have "sorted_wrt rel xs" by (simp)
moreover from 3(7) have "sorted_wrt rel ys" by (simp)
ultimately show "sorted_wrt rel (merge_wrt rel xs ys)" by (rule 3(1))
qed
next
case False
show ?thesis
proof (cases "rel x y")
case True
show ?thesis
proof (auto simp add: False True)
fix z
assume "z ∈ set (merge_wrt rel xs (y # ys))"
hence "z ∈ insert y (set xs ∪ set ys)" by (simp add: set_merge_wrt)
thus "rel x z"
proof
assume "z = y"
with True show ?thesis by simp
next
assume "z ∈ set xs ∪ set ys"
thus ?thesis
proof
assume "z ∈ set xs"
with 3(6) show ?thesis by (simp)
next
assume "z ∈ set ys"
with 3(7) have "rel y z" by (simp)
with 3(4) True show ?thesis by (rule transpD)
qed
qed
next
note False True 3(4, 5)
moreover from 3(6) have "sorted_wrt rel xs" by (simp)
ultimately show "sorted_wrt rel (merge_wrt rel xs (y # ys))" using 3(7) by (rule 3(2))
qed
next
assume "¬ rel x y"
from ‹x ≠ y› have "rel x y ∨ rel y x" by (rule 3(5))
with ‹¬ rel x y› have *: "rel y x" by simp
show ?thesis
proof (auto simp add: False ‹¬ rel x y›)
fix z
assume "z ∈ set (merge_wrt rel (x # xs) ys)"
hence "z ∈ insert x (set xs ∪ set ys)" by (simp add: set_merge_wrt)
thus "rel y z"
proof
assume "z = x"
with * show ?thesis by simp
next
assume "z ∈ set xs ∪ set ys"
thus ?thesis
proof
assume "z ∈ set xs"
with 3(6) have "rel x z" by (simp)
with 3(4) * show ?thesis by (rule transpD)
next
assume "z ∈ set ys"
with 3(7) show ?thesis by (simp)
qed
qed
next
note False ‹¬ rel x y› 3(4, 5, 6)
moreover from 3(7) have "sorted_wrt rel ys" by (simp)
ultimately show "sorted_wrt rel (merge_wrt rel (x # xs) ys)" by (rule 3(3))
qed
qed
qed
qed
lemma set_fold:
assumes "⋀x ys. set (f (g x) ys) = set (g x) ∪ set ys"
shows "set (fold (λx. f (g x)) xs ys) = (⋃x∈set xs. set (g x)) ∪ set ys"
proof (induct xs arbitrary: ys)
case Nil
show ?case by simp
next
case (Cons x xs)
have eq: "set (fold (λx. f (g x)) xs (f (g x) ys)) = (⋃x∈set xs. set (g x)) ∪ set (f (g x) ys)"
by (rule Cons)
show ?case by (simp add: o_def assms set_merge_wrt eq ac_simps)
qed
subsection ‹Sums and Products›
lemma additive_implies_homogenous:
assumes "⋀x y. f (x + y) = f x + ((f (y::'a::monoid_add))::'b::cancel_comm_monoid_add)"
shows "f 0 = 0"
proof -
have "f (0 + 0) = f 0 + f 0" by (rule assms)
hence "f 0 = f 0 + f 0" by simp
thus "f 0 = 0" by simp
qed
lemma fun_sum_commute:
assumes "f 0 = 0" and "⋀x y. f (x + y) = f x + f y"
shows "f (sum g A) = (∑a∈A. f (g a))"
proof (cases "finite A")
case True
thus ?thesis
proof (induct A)
case empty
thus ?case by (simp add: assms(1))
next
case step: (insert a A)
show ?case by (simp add: sum.insert[OF step(1) step(2)] assms(2) step(3))
qed
next
case False
thus ?thesis by (simp add: assms(1))
qed
lemma fun_sum_commute_canc:
assumes "⋀x y. f (x + y) = f x + ((f y)::'a::cancel_comm_monoid_add)"
shows "f (sum g A) = (∑a∈A. f (g a))"
by (rule fun_sum_commute, rule additive_implies_homogenous, fact+)
lemma fun_sum_list_commute:
assumes "f 0 = 0" and "⋀x y. f (x + y) = f x + f y"
shows "f (sum_list xs) = sum_list (map f xs)"
proof (induct xs)
case Nil
thus ?case by (simp add: assms(1))
next
case (Cons x xs)
thus ?case by (simp add: assms(2))
qed
lemma fun_sum_list_commute_canc:
assumes "⋀x y. f (x + y) = f x + ((f y)::'a::cancel_comm_monoid_add)"
shows "f (sum_list xs) = sum_list (map f xs)"
by (rule fun_sum_list_commute, rule additive_implies_homogenous, fact+)
lemma sum_set_upt_eq_sum_list: "(∑i = m..<n. f i) = (∑i←[m..<n]. f i)"
using sum_set_upt_conv_sum_list_nat by auto
lemma sum_list_upt: "(∑i←[0..<(length xs)]. f (xs ! i)) = (∑x←xs. f x)"
by (simp only: map_upt)
lemma sum_list_upt_zip:
assumes "length xs = length ys"
shows "(∑i←[0..<(length ys)]. f (xs ! i) (ys ! i)) = (∑(x, y)←(zip xs ys). f x y)"
by (simp only: map_upt_zip[OF assms])
lemma sum_list_zeroI:
assumes "set xs ⊆ {0}"
shows "sum_list xs = 0"
using assms by (induct xs, auto)
lemma fun_prod_commute:
assumes "f 1 = 1" and "⋀x y. f (x * y) = f x * f y"
shows "f (prod g A) = (∏a∈A. f (g a))"
proof (cases "finite A")
case True
thus ?thesis
proof (induct A)
case empty
thus ?case by (simp add: assms(1))
next
case step: (insert a A)
show ?case by (simp add: prod.insert[OF step(1) step(2)] assms(2) step(3))
qed
next
case False
thus ?thesis by (simp add: assms(1))
qed
end
Theory MPoly_Type
section ‹An abstract type for multivariate polynomials›
theory MPoly_Type
imports "HOL-Library.Poly_Mapping"
begin
subsection ‹Abstract type definition›
typedef (overloaded) 'a mpoly =
"UNIV :: ((nat ⇒⇩0 nat) ⇒⇩0 'a::zero) set"
morphisms mapping_of MPoly
..
setup_lifting type_definition_mpoly
thm mapping_of_inverse thm MPoly_inverse
thm mapping_of_inject thm MPoly_inject
thm mapping_of_induct thm MPoly_induct
thm mapping_of_cases thm MPoly_cases
subsection ‹Additive structure›
instantiation mpoly :: (zero) zero
begin
lift_definition zero_mpoly :: "'a mpoly"
is "0 :: (nat ⇒⇩0 nat) ⇒⇩0 'a" .
instance ..
end
instantiation mpoly :: (monoid_add) monoid_add
begin
lift_definition plus_mpoly :: "'a mpoly ⇒ 'a mpoly ⇒ 'a mpoly"
is "Groups.plus :: ((nat ⇒⇩0 nat) ⇒⇩0 'a) ⇒ _" .
instance
by intro_classes (transfer, simp add: fun_eq_iff add.assoc)+
end
instance mpoly :: (comm_monoid_add) comm_monoid_add
by intro_classes (transfer, simp add: fun_eq_iff ac_simps)+
instantiation mpoly :: (cancel_comm_monoid_add) cancel_comm_monoid_add
begin
lift_definition minus_mpoly :: "'a mpoly ⇒ 'a mpoly ⇒ 'a mpoly"
is "Groups.minus :: ((nat ⇒⇩0 nat) ⇒⇩0 'a) ⇒ _" .
instance
by intro_classes (transfer, simp add: fun_eq_iff diff_diff_add)+
end
instantiation mpoly :: (ab_group_add) ab_group_add
begin
lift_definition uminus_mpoly :: "'a mpoly ⇒ 'a mpoly"
is "Groups.uminus :: ((nat ⇒⇩0 nat) ⇒⇩0 'a) ⇒ _" .
instance
by intro_classes (transfer, simp add: fun_eq_iff add_uminus_conv_diff)+
end
subsection ‹Multiplication by a coefficient›
lift_definition smult :: "'a::{times,zero} ⇒ 'a mpoly ⇒ 'a mpoly"
is "λa. Poly_Mapping.map (Groups.times a) :: ((nat ⇒⇩0 nat) ⇒⇩0 'a) ⇒ _" .
subsection ‹Multiplicative structure›
instantiation mpoly :: (zero_neq_one) zero_neq_one
begin
lift_definition one_mpoly :: "'a mpoly"
is "1 :: ((nat ⇒⇩0 nat) ⇒⇩0 'a)" .
instance
by intro_classes (transfer, simp)
end
instantiation mpoly :: (semiring_0) semiring_0
begin
lift_definition times_mpoly :: "'a mpoly ⇒ 'a mpoly ⇒ 'a mpoly"
is "Groups.times :: ((nat ⇒⇩0 nat) ⇒⇩0 'a) ⇒ _" .
instance
by intro_classes (transfer, simp add: algebra_simps)+
end
instance mpoly :: (comm_semiring_0) comm_semiring_0
by intro_classes (transfer, simp add: algebra_simps)+
instance mpoly :: (semiring_0_cancel) semiring_0_cancel
..
instance mpoly :: (comm_semiring_0_cancel) comm_semiring_0_cancel
..
instance mpoly :: (semiring_1) semiring_1
by intro_classes (transfer, simp)+
instance mpoly :: (comm_semiring_1) comm_semiring_1
by intro_classes (transfer, simp)+
instance mpoly :: (semiring_1_cancel) semiring_1_cancel
..
instance mpoly :: (ring) ring
..
instance mpoly :: (comm_ring) comm_ring
..
instance mpoly :: (ring_1) ring_1
..
instance mpoly :: (comm_ring_1) comm_ring_1
..
subsection ‹Monomials›
text ‹
Terminology is not unique here, so we use the notions as follows:
A "monomial" and a "coefficient" together give a "term".
These notions are significant in connection with "leading",
"leading term", "leading coefficient" and "leading monomial",
which all rely on a monomial order.
›
lift_definition monom :: "(nat ⇒⇩0 nat) ⇒ 'a::zero ⇒ 'a mpoly"
is "Poly_Mapping.single :: (nat ⇒⇩0 nat) ⇒ _" .
lemma mapping_of_monom [simp]:
"mapping_of (monom m a) = Poly_Mapping.single m a"
by(fact monom.rep_eq)
lemma monom_zero [simp]:
"monom 0 0 = 0"
by transfer simp
lemma monom_one [simp]:
"monom 0 1 = 1"
by transfer simp
lemma monom_add:
"monom m (a + b) = monom m a + monom m b"
by transfer (simp add: single_add)
lemma monom_uminus:
"monom m (- a) = - monom m a"
by transfer (simp add: single_uminus)
lemma monom_diff:
"monom m (a - b) = monom m a - monom m b"
by transfer (simp add: single_diff)
lemma monom_numeral [simp]:
"monom 0 (numeral n) = numeral n"
by (induct n) (simp_all only: numeral.simps numeral_add monom_zero monom_one monom_add)
lemma monom_of_nat [simp]:
"monom 0 (of_nat n) = of_nat n"
by (induct n) (simp_all add: monom_add)
lemma of_nat_monom:
"of_nat = monom 0 ∘ of_nat"
by (simp add: fun_eq_iff)
lemma inj_monom [iff]:
"inj (monom m)"
proof (rule injI, transfer)
fix a b :: 'a and m :: "nat ⇒⇩0 nat"
assume "Poly_Mapping.single m a = Poly_Mapping.single m b"
with injD [of "Poly_Mapping.single m" a b]
show "a = b" by simp
qed
lemma mult_monom: "monom x a * monom y b = monom (x + y) (a * b)"
by transfer' (simp add: Poly_Mapping.mult_single)
instance mpoly :: (semiring_char_0) semiring_char_0
by intro_classes (auto simp add: of_nat_monom inj_of_nat intro: inj_compose)
instance mpoly :: (ring_char_0) ring_char_0
..
lemma monom_of_int [simp]:
"monom 0 (of_int k) = of_int k"
apply (cases k)
apply simp_all
unfolding monom_diff monom_uminus
apply simp
done
subsection ‹Constants and Indeterminates›
text ‹Embedding of indeterminates and constants in type-class polynomials,
can be used as constructors.›
definition Var⇩0 :: "'a ⇒ ('a ⇒⇩0 nat) ⇒⇩0 'b::{one,zero}" where
"Var⇩0 n ≡ Poly_Mapping.single (Poly_Mapping.single n 1) 1"
definition Const⇩0 :: "'b ⇒ ('a ⇒⇩0 nat) ⇒⇩0 'b::zero" where "Const⇩0 c ≡ Poly_Mapping.single 0 c"
lemma Const⇩0_one: "Const⇩0 1 = 1"
by (simp add: Const⇩0_def)
lemma Const⇩0_numeral: "Const⇩0 (numeral x) = numeral x"
by (auto intro!: poly_mapping_eqI simp: Const⇩0_def lookup_numeral)
lemma Const⇩0_minus: "Const⇩0 (- x) = - Const⇩0 x"
by (simp add: Const⇩0_def single_uminus)
lemma Const⇩0_zero: "Const⇩0 0 = 0"
by (auto intro!: poly_mapping_eqI simp: Const⇩0_def)
lemma Var⇩0_power: "Var⇩0 v ^ n = Poly_Mapping.single (Poly_Mapping.single v n) 1"
by (induction n) (auto simp: Var⇩0_def mult_single single_add[symmetric])
lift_definition Var::"nat ⇒ 'b::{one,zero} mpoly" is Var⇩0 .
lift_definition Const::"'b::zero ⇒ 'b mpoly" is Const⇩0 .
subsection ‹Integral domains›
instance mpoly :: (ring_no_zero_divisors) ring_no_zero_divisors
by intro_classes (transfer, simp)
instance mpoly :: (ring_1_no_zero_divisors) ring_1_no_zero_divisors
..
instance mpoly :: (idom) idom
..
subsection ‹Monom coefficient lookup›
definition coeff :: "'a::zero mpoly ⇒ (nat ⇒⇩0 nat) ⇒ 'a"
where
"coeff p = Poly_Mapping.lookup (mapping_of p)"
subsection ‹Insertion morphism›
definition insertion_fun_natural :: "(nat ⇒ 'a) ⇒ ((nat ⇒ nat) ⇒ 'a) ⇒ 'a::comm_semiring_1"
where
"insertion_fun_natural f p = (∑m. p m * (∏v. f v ^ m v))"
definition insertion_fun :: "(nat ⇒ 'a) ⇒ ((nat ⇒⇩0 nat) ⇒ 'a) ⇒ 'a::comm_semiring_1"
where
"insertion_fun f p = (∑m. p m * (∏v. f v ^ Poly_Mapping.lookup m v))"
text ‹N.b. have been unable to relate this to @{const insertion_fun_natural} using lifting!›
lift_definition insertion_aux :: "(nat ⇒ 'a) ⇒ ((nat ⇒⇩0 nat) ⇒⇩0 'a) ⇒ 'a::comm_semiring_1"
is "insertion_fun" .
lift_definition insertion :: "(nat ⇒ 'a) ⇒ 'a mpoly ⇒ 'a::comm_semiring_1"
is "insertion_aux" .
lemma aux:
"Poly_Mapping.lookup f = (λ_. 0) ⟷ f = 0"
apply transfer apply simp done
lemma insertion_trivial [simp]:
"insertion (λ_. 0) p = coeff p 0"
proof -
{ fix f :: "(nat ⇒⇩0 nat) ⇒⇩0 'a"
have "insertion_aux (λ_. 0) f = Poly_Mapping.lookup f 0"
apply (simp add: insertion_aux_def insertion_fun_def power_Sum_any [symmetric])
apply (simp add: zero_power_eq mult_when aux)
done
}
then show ?thesis by (simp add: coeff_def insertion_def)
qed
lemma insertion_zero [simp]:
"insertion f 0 = 0"
by transfer (simp add: insertion_aux_def insertion_fun_def)
lemma insertion_fun_add:
fixes f p q
shows "insertion_fun f (Poly_Mapping.lookup (p + q)) =
insertion_fun f (Poly_Mapping.lookup p) +
insertion_fun f (Poly_Mapping.lookup q)"
unfolding insertion_fun_def
apply (subst Sum_any.distrib [symmetric])
apply (simp_all add: plus_poly_mapping.rep_eq algebra_simps)
apply (rule finite_mult_not_eq_zero_rightI)
apply simp
apply (rule finite_mult_not_eq_zero_rightI)
apply simp
done
lemma insertion_add:
"insertion f (p + q) = insertion f p + insertion f q"
by transfer (simp add: insertion_aux_def insertion_fun_add)
lemma insertion_one [simp]:
"insertion f 1 = 1"
by transfer (simp add: insertion_aux_def insertion_fun_def one_poly_mapping.rep_eq when_mult)
lemma insertion_fun_mult:
fixes f p q
shows "insertion_fun f (Poly_Mapping.lookup (p * q)) =
insertion_fun f (Poly_Mapping.lookup p) *
insertion_fun f (Poly_Mapping.lookup q)"
proof -
{ fix m :: "nat ⇒⇩0 nat"
have "finite {v. Poly_Mapping.lookup m v ≠ 0}"
by simp
then have "finite {v. f v ^ Poly_Mapping.lookup m v ≠ 1}"
by (rule rev_finite_subset) (auto intro: ccontr)
}
moreover define g where "g m = (∏v. f v ^ Poly_Mapping.lookup m v)" for m
ultimately have *: "⋀a b. g (a + b) = g a * g b"
by (simp add: plus_poly_mapping.rep_eq power_add Prod_any.distrib)
have bij: "bij (λ(l, n, m). (m, l, n))"
by (auto intro!: bijI injI simp add: image_def)
let ?P = "{l. Poly_Mapping.lookup p l ≠ 0}"
let ?Q = "{n. Poly_Mapping.lookup q n ≠ 0}"
let ?PQ = "{l + n | l n. l ∈ Poly_Mapping.keys p ∧ n ∈ Poly_Mapping.keys q}"
have "finite {l + n | l n. Poly_Mapping.lookup p l ≠ 0 ∧ Poly_Mapping.lookup q n ≠ 0}"
by (rule finite_not_eq_zero_sumI) simp_all
then have fin_PQ: "finite ?PQ"
by (simp add: in_keys_iff)
have "(∑m. Poly_Mapping.lookup (p * q) m * g m) =
(∑m. (∑l. Poly_Mapping.lookup p l * (∑n. Poly_Mapping.lookup q n when m = l + n)) * g m)"
by (simp add: times_poly_mapping.rep_eq prod_fun_def)
also have "… = (∑m. (∑l. (∑n. g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)))"
apply (subst Sum_any_left_distrib)
apply (auto intro: finite_mult_not_eq_zero_rightI)
apply (subst Sum_any_right_distrib)
apply (auto intro: finite_mult_not_eq_zero_rightI)
apply (subst Sum_any_left_distrib)
apply (auto intro: finite_mult_not_eq_zero_leftI)
apply (simp add: ac_simps mult_when)
done
also have "… = (∑m. (∑(l, n). g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n))"
apply (subst (2) Sum_any.cartesian_product [of "?P × ?Q"])
apply (auto dest!: mult_not_zero)
done
also have "… = (∑(m, l, n). g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)"
apply (subst Sum_any.cartesian_product [of "?PQ × (?P × ?Q)"])
apply (auto dest!: mult_not_zero simp add: fin_PQ)
apply (auto simp: in_keys_iff)
done
also have "… = (∑(l, n, m). g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)"
using bij by (rule Sum_any.reindex_cong [of "λ(l, n, m). (m, l, n)"]) (simp add: fun_eq_iff)
also have "… = (∑(l, n). ∑m. g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)"
apply (subst Sum_any.cartesian_product2 [of "(?P × ?Q) × ?PQ"])
apply (auto dest!: mult_not_zero simp add: fin_PQ )
apply (auto simp: in_keys_iff)
done
also have "… = (∑(l, n). (g l * g n) * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n))"
by (simp add: *)
also have "… = (∑l. ∑n. (g l * g n) * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n))"
apply (subst Sum_any.cartesian_product [of "?P × ?Q"])
apply (auto dest!: mult_not_zero)
done
also have "… = (∑l. ∑n. (Poly_Mapping.lookup p l * g l) * (Poly_Mapping.lookup q n * g n))"
by (simp add: ac_simps)
also have "… =
(∑m. Poly_Mapping.lookup p m * g m) *
(∑m. Poly_Mapping.lookup q m * g m)"
by (rule Sum_any_product [symmetric]) (auto intro: finite_mult_not_eq_zero_rightI)
finally show ?thesis by (simp add: insertion_fun_def g_def)
qed
lemma insertion_mult:
"insertion f (p * q) = insertion f p * insertion f q"
by transfer (simp add: insertion_aux_def insertion_fun_mult)
subsection ‹Degree›
lift_definition degree :: "'a::zero mpoly ⇒ nat ⇒ nat"
is "λp v. Max (insert 0 ((λm. Poly_Mapping.lookup m v) ` Poly_Mapping.keys p))" .
lift_definition total_degree :: "'a::zero mpoly ⇒ nat"
is "λp. Max (insert 0 ((λm. sum (Poly_Mapping.lookup m) (Poly_Mapping.keys m)) ` Poly_Mapping.keys p))" .
lemma degree_zero [simp]:
"degree 0 v = 0"
by transfer simp
lemma total_degree_zero [simp]:
"total_degree 0 = 0"
by transfer simp
lemma degree_one [simp]:
"degree 1 v = 0"
by transfer simp
lemma total_degree_one [simp]:
"total_degree 1 = 0"
by transfer simp
subsection ‹Pseudo-division of polynomials›
lemma smult_conv_mult: "smult s p = monom 0 s * p"
by transfer (simp add: mult_map_scale_conv_mult)
lemma smult_monom [simp]:
fixes c :: "_ :: mult_zero"
shows "smult c (monom x c') = monom x (c * c')"
by transfer simp
lemma smult_0 [simp]:
fixes p :: "_ :: mult_zero mpoly"
shows "smult 0 p = 0"
by transfer(simp add: map_eq_zero_iff)
lemma mult_smult_left: "smult s p * q = smult s (p * q)"
by(simp add: smult_conv_mult mult.assoc)
lift_definition sdiv :: "'a::euclidean_ring ⇒ 'a mpoly ⇒ 'a mpoly"
is "λa. Poly_Mapping.map (λb. b div a) :: ((nat ⇒⇩0 nat) ⇒⇩0 'a) ⇒ _"
.
text ‹
\qt{Polynomial division} is only possible on univariate polynomials ‹K[x]›
over a field ‹K›, all other kinds of polynomials only allow pseudo-division
[1]p.40/41":
‹∀x y :: 'a mpoly. y ≠ 0 ⇒ ∃a q r. smult a x = q * y + r›
The introduction of pseudo-division below generalises @{file ‹~~/src/HOL/Computational_Algebra/Polynomial.thy›}.
[1] Winkler, Polynomial Algorithms, 1996.
The generalisation raises issues addressed by Wenda Li and commented below.
Florian replied to the issues conjecturing, that the abstract mpoly needs not
be aware of the issues, in case these are only concerned with executability.
›
definition pseudo_divmod_rel
:: "'a::euclidean_ring => 'a mpoly => 'a mpoly => 'a mpoly => 'a mpoly => bool"
where
"pseudo_divmod_rel a x y q r ⟷
smult a x = q * y + r ∧ (if y = 0 then q = 0 else r = 0 ∨ degree r < degree y)"
definition pdiv :: "'a::euclidean_ring mpoly ⇒ 'a mpoly ⇒ ('a × 'a mpoly)" (infixl "pdiv" 70)
where
"x pdiv y = (THE (a, q). ∃r. pseudo_divmod_rel a x y q r)"
definition pmod :: "'a::euclidean_ring mpoly ⇒ 'a mpoly ⇒ 'a mpoly" (infixl "pmod" 70)
where
"x pmod y = (THE r. ∃a q. pseudo_divmod_rel a x y q r)"
definition pdivmod :: "'a::euclidean_ring mpoly ⇒ 'a mpoly ⇒ ('a × 'a mpoly) × 'a mpoly"
where
"pdivmod p q = (p pdiv q, p pmod q)"
lemma pdiv_code:
"p pdiv q = fst (pdivmod p q)"
by (simp add: pdivmod_def)
lemma pmod_code:
"p pmod q = snd (pdivmod p q)"
by (simp add: pdivmod_def)
definition div :: "'a::{euclidean_ring,field} mpoly ⇒ 'a mpoly ⇒ 'a mpoly" (infixl "div" 70)
where
"x div y = (THE q'. ∃a q r. (pseudo_divmod_rel a x y q r) ∧ (q' = smult (inverse a) q))"
definition mod :: "'a::{euclidean_ring,field} mpoly ⇒ 'a mpoly ⇒ 'a mpoly" (infixl "mod" 70)
where
"x mod y = (THE r'. ∃a q r. (pseudo_divmod_rel a x y q r) ∧ (r' = smult (inverse a) r))"
definition divmod :: "'a::{euclidean_ring,field} mpoly ⇒ 'a mpoly ⇒ 'a mpoly × 'a mpoly"
where
"divmod p q = (p div q, p mod q)"
lemma div_poly_code:
"p div q = fst (divmod p q)"
by (simp add: divmod_def)
lemma mod_poly_code:
"p mod q = snd (divmod p q)"
by (simp add: divmod_def)
subsection ‹Primitive poly, etc›
lift_definition coeffs :: "'a :: zero mpoly ⇒ 'a set"
is "Poly_Mapping.range :: ((nat ⇒⇩0 nat) ⇒⇩0 'a) ⇒ _" .
lemma finite_coeffs [simp]: "finite (coeffs p)"
by transfer simp
text ‹[1]p.82
A "primitive'" polynomial has coefficients with GCD equal to 1.
A polynomial is factored into "content" and "primitive part"
for many different purposes.›
definition primitive :: "'a::{euclidean_ring,semiring_Gcd} mpoly ⇒ bool"
where
"primitive p ⟷ Gcd (coeffs p) = 1"
definition content_primitive :: "'a::{euclidean_ring,GCD.Gcd} mpoly ⇒ 'a × 'a mpoly"
where
"content_primitive p = (
let d = Gcd (coeffs p)
in (d, sdiv d p))"
value "let p = M [1,2,3] (4::int) + M [2,0,4] 6 + M [2,0,5] 8
in content_primitive p"
end
Theory More_MPoly_Type
theory More_MPoly_Type
imports MPoly_Type
begin
abbreviation "lookup == Poly_Mapping.lookup"
abbreviation "keys == Poly_Mapping.keys"
section "MPpoly Mapping extenion"
lemma lookup_Abs_poly_mapping_when_finite:
assumes "finite S"
shows "lookup (Abs_poly_mapping (λx. f x when x∈S)) = (λx. f x when x∈S)"
proof -
have "finite {x. (f x when x∈S) ≠ 0}" using assms by auto
then show ?thesis using lookup_Abs_poly_mapping by fast
qed
definition remove_key::"'a ⇒ ('a ⇒⇩0 'b::monoid_add) ⇒ ('a ⇒⇩0 'b)" where
"remove_key k0 f = Abs_poly_mapping (λk. lookup f k when k ≠ k0)"
lemma remove_key_lookup:
"lookup (remove_key k0 f) k = (lookup f k when k ≠ k0)"
unfolding remove_key_def using finite_subset by (simp add: lookup_Abs_poly_mapping)
lemma remove_key_keys: "keys f - {k} = keys (remove_key k f)" (is "?A = ?B")
proof (rule antisym; rule subsetI)
fix x assume "x ∈ ?A"
then show "x ∈ ?B" using remove_key_lookup lookup_not_eq_zero_eq_in_keys DiffD1 DiffD2 insertCI
by (metis (mono_tags, lifting) when_def)
next
fix x assume "x ∈ ?B"
then have "lookup (remove_key k f) x ≠ 0" by blast
then show "x ∈ ?A"
by (simp add: lookup_not_eq_zero_eq_in_keys remove_key_lookup)
qed
lemma remove_key_sum: "remove_key k f + Poly_Mapping.single k (lookup f k) = f"
proof -
{
fix k'
have rem:"(lookup f k' when k' ≠ k) = lookup (remove_key k f) k'"
using when_def by (simp add: remove_key_lookup)
have sin:"(lookup f k when k'=k) = lookup (Poly_Mapping.single k (lookup f k)) k'"
by (simp add: lookup_single_not_eq when_def)
have "lookup f k' = (lookup f k' when k' ≠ k) + ((lookup f k) when k'=k)"
unfolding when_def by fastforce
with rem sin have "lookup f k' = lookup ((remove_key k f) + Poly_Mapping.single k (lookup f k)) k'"
using lookup_add by metis
}
then show ?thesis by (metis poly_mapping_eqI)
qed
lemma remove_key_single[simp]: "remove_key v (Poly_Mapping.single v n) = 0"
proof -
have 0:"⋀k. (lookup (Poly_Mapping.single v n) k when k ≠ v) = 0" by (simp add: lookup_single_not_eq when_def)
show ?thesis unfolding remove_key_def 0
by auto
qed
lemma remove_key_add: "remove_key v m + remove_key v m' = remove_key v (m + m')"
by (rule poly_mapping_eqI; simp add: lookup_add remove_key_lookup when_add_distrib)
lemma poly_mapping_induct [case_names single sum]:
fixes P::"('a, 'b::monoid_add) poly_mapping ⇒ bool"
assumes single:"⋀k v. P (Poly_Mapping.single k v)"
and sum:"(⋀f g k v. P f ⟹ P g ⟹ g = (Poly_Mapping.single k v) ⟹ k ∉ keys f ⟹ P (f+g))"
shows "P f" using finite_keys[of f]
proof (induction "keys f" arbitrary: f rule: finite_induct)
case (empty)
then show ?case using single[of _ 0] by (metis (full_types) aux empty_iff not_in_keys_iff_lookup_eq_zero single_zero)
next
case (insert k K f)
obtain f1 f2 where f12_def: "f1 = remove_key k f" "f2 = Poly_Mapping.single k (lookup f k)" by blast
have "P f1"
proof -
have "Suc (card (keys f1)) = card (keys f)"
using remove_key_keys finite_keys f12_def(1) by (metis (no_types) Diff_insert_absorb card_insert_disjoint insert.hyps(2) insert.hyps(4))
then show ?thesis using insert lessI by (metis Diff_insert_absorb f12_def(1) remove_key_keys)
qed
have "P f2" by (simp add: single f12_def(2))
have "f1 + f2 = f" using remove_key_sum f12_def by auto
have "k ∉ keys f1" using remove_key_keys f12_def by fast
then show ?case using ‹P f1› ‹P f2› sum[of f1 f2 k "lookup f k"] ‹f1 + f2 = f› f12_def by auto
qed
lemma map_lookup:
assumes "g 0 = 0"
shows "lookup (Poly_Mapping.map g f) x = g ((lookup f) x)"
proof -
have "(g (lookup f x) when lookup f x ≠ 0) = g (lookup f x)"
by (metis (mono_tags, lifting) assms when_def)
then have "(g (lookup f x) when x ∈ keys f) = g (lookup f x)"
using lookup_not_eq_zero_eq_in_keys [of f] by simp
then show ?thesis
by (simp add: Poly_Mapping.map_def map_fun_def in_keys_iff)
qed
lemma keys_add:
assumes "keys f ∩ keys g = {}"
shows "keys f ∪ keys g = keys (f+g)"
proof
have "keys f ⊆ keys (f+g)"
proof
fix x assume "x∈keys f"
then have "lookup (f+g) x = lookup f x " by (metis add.right_neutral assms disjoint_iff_not_equal not_in_keys_iff_lookup_eq_zero plus_poly_mapping.rep_eq)
then show "x∈keys (f+g)" using ‹x∈keys f› by (metis not_in_keys_iff_lookup_eq_zero)
qed
moreover have "keys g ⊆ keys (f+g)"
proof
fix x assume "x∈keys g"
then have "lookup (f+g) x = lookup g x " by (metis IntI add.left_neutral assms empty_iff not_in_keys_iff_lookup_eq_zero plus_poly_mapping.rep_eq)
then show "x∈keys (f+g)" using ‹x∈keys g› by (metis not_in_keys_iff_lookup_eq_zero)
qed
ultimately show "keys f ∪ keys g ⊆ keys (f+g)" by simp
next
show "keys (f + g) ⊆ keys f ∪ keys g" by (simp add: keys_add)
qed
lemma fun_when:
"f 0 = 0 ⟹ f (a when P) = (f a when P)" by (simp add: when_def)
section "MPoly extension"
lemma coeff_all_0:"(⋀m. coeff p m = 0) ⟹ p=0"
by (metis aux coeff_def mapping_of_inject zero_mpoly.rep_eq)
definition vars::"'a::zero mpoly ⇒ nat set" where
"vars p = ⋃ (keys ` keys (mapping_of p))"
lemma vars_finite: "finite (vars p)" unfolding vars_def by auto
lemma vars_monom_single: "vars (monom (Poly_Mapping.single v k) a) ⊆ {v}"
proof
fix w assume "w ∈ vars (monom (Poly_Mapping.single v k) a)"
then have "w = v" using vars_def by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq monom.rep_eq)
then show "w ∈ {v}" by auto
qed
lemma vars_monom_keys:
assumes "a≠0"
shows "vars (monom m a) = keys m"
proof (rule antisym; rule subsetI)
fix w assume "w ∈ vars (monom m a)"
then have "lookup m w ≠ 0" using vars_def by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq monom.rep_eq)
then show "w ∈ keys m" by (meson lookup_not_eq_zero_eq_in_keys)
next
fix w assume "w ∈ keys m"
then have "lookup m w ≠ 0" by (meson lookup_not_eq_zero_eq_in_keys)
then show "w ∈ vars (monom m a)" unfolding vars_def using assms by (metis UN_iff lookup_not_eq_zero_eq_in_keys lookup_single_eq monom.rep_eq)
qed
lemma vars_monom_subset:
shows "vars (monom m a) ⊆ keys m"
by (cases "a=0"; simp add: vars_def vars_monom_keys)
lemma vars_monom_single_cases: "vars (monom (Poly_Mapping.single v k) a) = (if k=0 ∨ a=0 then {} else {v})"
proof(cases "k=0")
assume "k=0"
then have "(Poly_Mapping.single v k) = 0" by simp
then have "vars (monom (Poly_Mapping.single v k) a) = {}"
by (metis (mono_tags, lifting) single_zero singleton_inject subset_singletonD vars_monom_single zero_neq_one)
then show ?thesis using ‹k=0› by auto
next
assume "k≠0"
then show ?thesis
proof (cases "a=0")
assume "a=0"
then have "monom (Poly_Mapping.single v k) a = 0" by (metis monom.abs_eq monom_zero single_zero)
then show ?thesis by (metis (mono_tags, hide_lams) ‹k ≠ 0› ‹a=0› monom.abs_eq single_zero singleton_inject subset_singletonD vars_monom_single)
next
assume "a≠0"
then have "v ∈ vars (monom (Poly_Mapping.single v k) a)" by (simp add: ‹k ≠ 0› vars_def)
then show ?thesis using ‹a≠0› ‹k ≠ 0› vars_monom_single by fastforce
qed
qed
lemma vars_monom:
assumes "a≠0"
shows "vars (monom m (1::'a::zero_neq_one)) = vars (monom m (a::'a))"
unfolding vars_monom_keys[OF assms] using vars_monom_keys[of 1] one_neq_zero by blast
lemma vars_add: "vars (p1 + p2) ⊆ vars p1 ∪ vars p2"
proof
fix w assume "w ∈ vars (p1 + p2)"
then obtain m where "w ∈ keys m" "m ∈ keys (mapping_of (p1 + p2))" by (metis UN_E vars_def)
then have "m ∈ keys (mapping_of (p1)) ∪ keys (mapping_of (p2))"
by (metis Poly_Mapping.keys_add plus_mpoly.rep_eq subset_iff)
then show "w ∈ vars p1 ∪ vars p2" using vars_def ‹w ∈ keys m› by fastforce
qed
lemma vars_mult: "vars (p*q) ⊆ vars p ∪ vars q"
proof
fix x assume "x∈vars (p*q)"
then obtain m where "m∈keys (mapping_of (p*q))" "x∈keys m"
using vars_def by blast
then have "m∈keys (mapping_of p * mapping_of q)"
by (simp add: times_mpoly.rep_eq)
then obtain a b where "m=a + b" "a ∈ keys (mapping_of p)" "b ∈ keys (mapping_of q)"
using keys_mult by blast
then have "x ∈ keys a ∪ keys b"
using Poly_Mapping.keys_add ‹x ∈ keys m› by force
then show "x ∈ vars p ∪ vars q" unfolding vars_def
using ‹a ∈ keys (mapping_of p)› ‹b ∈ keys (mapping_of q)› by blast
qed
lemma vars_add_monom:
assumes "p2 = monom m a" "m ∉ keys (mapping_of p1)"
shows "vars (p1 + p2) = vars p1 ∪ vars p2"
proof -
have "keys (mapping_of p2) ⊆ {m}" using monom_def keys_single assms by auto
have "keys (mapping_of (p1+p2)) = keys (mapping_of p1) ∪ keys (mapping_of p2)"
using keys_add by (metis Int_insert_right_if0 ‹keys (mapping_of p2) ⊆ {m}› assms(2) inf_bot_right plus_mpoly.rep_eq subset_singletonD)
then show ?thesis unfolding vars_def by simp
qed
lemma vars_setsum: "finite S ⟹ vars (∑m∈S. f m) ⊆ (⋃m∈S. vars (f m))"
proof (induction S rule:finite_induct)
case empty
then show ?case by (metis UN_empty eq_iff monom_zero sum.empty single_zero vars_monom_single_cases)
next
case (insert s S)
then have "vars (sum f (insert s S)) = vars (f s + sum f S)" by (metis sum.insert)
also have "... ⊆ vars (f s) ∪ vars (sum f S)" by (simp add: vars_add)
also have "... ⊆ (⋃m∈insert s S. vars (f m))" using insert.IH by auto
finally show ?case by metis
qed
lemma coeff_monom: "coeff (monom m a) m' = (a when m'=m)"
by (simp add: coeff_def lookup_single_not_eq when_def)
lemma coeff_add: "coeff p m + coeff q m = coeff (p+q) m"
by (simp add: coeff_def lookup_add plus_mpoly.rep_eq)
lemma coeff_eq: "coeff p = coeff q ⟷ p=q" by (simp add: coeff_def lookup_inject mapping_of_inject)
lemma coeff_monom_mult: "coeff ((monom m' a) * q) (m' + m) = a * coeff q m"
unfolding coeff_def times_mpoly.rep_eq lookup_mult mapping_of_monom lookup_single when_mult
Sum_any_when_equal' Groups.cancel_semigroup_add_class.add_left_cancel by metis
lemma one_term_is_monomial:
assumes "card (keys (mapping_of p)) ≤ 1"
obtains m where "p = monom m (coeff p m)"
proof (cases "keys (mapping_of p) = {}")
case True
then show ?thesis using aux coeff_def empty_iff mapping_of_inject mapping_of_monom not_in_keys_iff_lookup_eq_zero single_zero by (metis (no_types) that)
next
case False
then obtain m where "keys (mapping_of p) = {m}" using assms by (metis One_nat_def Suc_leI antisym card_0_eq card_eq_SucD finite_keys neq0_conv)
have "p = monom m (coeff p m)"
unfolding mapping_of_inject[symmetric]
by (rule poly_mapping_eqI, metis (no_types, lifting) ‹keys (mapping_of p) = {m}›
coeff_def keys_single lookup_single_eq mapping_of_monom not_in_keys_iff_lookup_eq_zero
singletonD)
then show ?thesis ..
qed
definition remove_term::"(nat ⇒⇩0 nat) ⇒ 'a::zero mpoly ⇒ 'a mpoly" where
"remove_term m0 p = MPoly (Abs_poly_mapping (λm. coeff p m when m ≠ m0))"
lemma remove_term_coeff: "coeff (remove_term m0 p) m = (coeff p m when m ≠ m0)"
proof -
have "{m. (coeff p m when m ≠ m0) ≠ 0} ⊆ {m. coeff p m ≠ 0}" by auto
then have "finite {m. (coeff p m when m ≠ m0) ≠ 0}" unfolding coeff_def using finite_subset by auto
then have "lookup (Abs_poly_mapping (λm. coeff p m when m ≠ m0)) m = (coeff p m when m ≠ m0)" using lookup_Abs_poly_mapping by fastforce
then show ?thesis unfolding remove_term_def using coeff_def by (metis (mono_tags, lifting) Quotient_mpoly Quotient_rep_abs_fold_unmap)
qed
lemma coeff_keys: "m ∈ keys (mapping_of p) ⟷ coeff p m ≠ 0"
by (simp add: coeff_def in_keys_iff)
lemma remove_term_keys:
shows "keys (mapping_of p) - {m} = keys (mapping_of (remove_term m p))" (is "?A = ?B")
proof
show "?A ⊆ ?B"
proof
fix m' assume "m'∈?A"
then show "m' ∈ ?B" by (simp add: coeff_keys remove_term_coeff)
qed
show "?B ⊆ ?A"
proof
fix m' assume "m'∈ ?B"
then show "m' ∈ ?A" by (simp add: coeff_keys remove_term_coeff)
qed
qed
lemma remove_term_sum: "remove_term m p + monom m (coeff p m) = p"
proof -
have "coeff p = (λm'. (coeff p m' when m' ≠ m) + ((coeff p m) when m'=m))" unfolding when_def by fastforce
moreover have "coeff (remove_term m p + monom m (coeff p m)) = ..."
using remove_term_coeff coeff_monom coeff_add by (metis (no_types))
ultimately show ?thesis using coeff_eq by auto
qed
lemma mpoly_induct [case_names monom sum]:
assumes monom:"⋀m a. P (monom m a)"
and sum:"(⋀p1 p2 m a. P p1 ⟹ P p2 ⟹ p2 = (monom m a) ⟹ m ∉ keys (mapping_of p1) ⟹ P (p1+p2))"
shows "P p" using assms
using poly_mapping_induct[of "λp :: (nat ⇒⇩0 nat) ⇒⇩0 'a. P (MPoly p)"] MPoly_induct monom.abs_eq plus_mpoly.abs_eq
by (metis (no_types) MPoly_inverse UNIV_I)
lemma monom_pow:"monom (Poly_Mapping.single v n0) a ^ n = monom (Poly_Mapping.single v (n0*n)) (a ^ n)"
apply (induction n)
apply auto
by (metis (no_types, lifting) mult_monom single_add)
lemma insertion_fun_single: "insertion_fun f (λm. (a when (Poly_Mapping.single (v::nat) (n::nat)) = m)) = a * f v ^ n" (is "?i = _")
proof -
have setsum_single:"⋀ a f. (∑m∈{a}. f m) = f a"
by (metis add.right_neutral empty_Diff finite.emptyI sum.empty sum.insert_remove)
have 1:"?i = (∑m. (a when Poly_Mapping.single v n = m) * (∏v. f v ^ lookup m v))"
unfolding insertion_fun_def by metis
have "∀m. m ≠ Poly_Mapping.single v n ⟶ (a when Poly_Mapping.single v n = m) = 0" by simp
have "(∑m∈{Poly_Mapping.single v n}. (a when Poly_Mapping.single v n = m) * (∏v. f v ^ lookup m v)) = ?i"
unfolding 1 when_mult unfolding when_def by auto
then have 2:"?i = a * (∏va. f va ^ lookup (Poly_Mapping.single v n) va)"
unfolding setsum_single[of "λm. (a when Poly_Mapping.single v n = m) * (∏v. f v ^ lookup m v)" "Poly_Mapping.single k v"]
by auto
have "∀v0. v0≠v ⟶ lookup (Poly_Mapping.single v n) v0 = 0" by (simp add: lookup_single_not_eq)
then have "∀va. va≠v ⟶ f va ^ lookup (Poly_Mapping.single v n) va = 1" by simp
then have "a * (∏va∈{v}. f va ^ lookup (Poly_Mapping.single v n) va) = ?i" unfolding 2
using Prod_any.expand_superset[of "{v}" "λva. f va ^ lookup (Poly_Mapping.single v n) va", simplified]
by fastforce
then show ?thesis by simp
qed
lemma insertion_single[simp]: "insertion f (monom (Poly_Mapping.single (v::nat) (n::nat)) a) = a * f v ^ n"
using insertion_fun_single Sum_any.cong insertion.rep_eq insertion_aux.rep_eq insertion_fun_def
mapping_of_monom single.rep_eq by (metis (no_types, lifting))
lemma insertion_fun_irrelevant_vars:
fixes p::"((nat ⇒⇩0 nat) ⇒ 'a::comm_ring_1)"
assumes "⋀m v. p m ≠ 0 ⟹ lookup m v ≠ 0 ⟹ f v = g v"
shows "insertion_fun f p = insertion_fun g p"
proof -
{
fix m::"nat⇒⇩0nat"
assume "p m ≠ 0"
then have "(∏v. f v ^ lookup m v) = (∏v. g v ^ lookup m v)"
using assms by (metis power_0)
}
then show ?thesis unfolding insertion_fun_def by (metis (no_types, lifting) mult_not_zero)
qed
lemma insertion_aux_irrelevant_vars:
fixes p::"((nat ⇒⇩0 nat) ⇒⇩0 'a::comm_ring_1)"
assumes "⋀m v. lookup p m ≠ 0 ⟹ lookup m v ≠ 0 ⟹ f v = g v"
shows "insertion_aux f p = insertion_aux g p"
using insertion_fun_irrelevant_vars[of "lookup p" f g] assms
by (metis insertion_aux.rep_eq)
lemma insertion_irrelevant_vars:
fixes p::"'a::comm_ring_1 mpoly"
assumes "⋀v. v∈vars p ⟹ f v = g v"
shows "insertion f p = insertion g p"
proof -
{
fix m v assume "lookup (mapping_of p) m ≠ 0" "lookup m v ≠ 0"
then have "v ∈ vars p" unfolding vars_def by (meson UN_I lookup_not_eq_zero_eq_in_keys)
then have "f v = g v" using assms by auto
}
then show ?thesis
unfolding insertion_def using insertion_aux_irrelevant_vars[of "mapping_of p"]
by (metis insertion.rep_eq insertion_def)
qed
section "Nested MPoly"
definition reduce_nested_mpoly::"'a::comm_ring_1 mpoly mpoly ⇒ 'a mpoly" where
"reduce_nested_mpoly pp = insertion (λv. monom (Poly_Mapping.single v 1) 1) pp"
lemma reduce_nested_mpoly_sum:
fixes p1::"'a::comm_ring_1 mpoly mpoly"
shows "reduce_nested_mpoly (p1 + p2) = reduce_nested_mpoly p1 + reduce_nested_mpoly p2"
by (simp add: insertion_add reduce_nested_mpoly_def)
lemma reduce_nested_mpoly_prod:
fixes p1::"'a::comm_ring_1 mpoly mpoly"
shows "reduce_nested_mpoly (p1 * p2) = reduce_nested_mpoly p1 * reduce_nested_mpoly p2"
by (simp add: insertion_mult reduce_nested_mpoly_def)
lemma reduce_nested_mpoly_0:
shows "reduce_nested_mpoly 0 = 0" by (simp add: reduce_nested_mpoly_def)
lemma insertion_nested_poly:
fixes pp::"'a::comm_ring_1 mpoly mpoly"
shows "insertion f (insertion (λv. monom 0 (f v)) pp) = insertion f (reduce_nested_mpoly pp)"
proof (induction pp rule:mpoly_induct)
case (monom m a)
then show ?case
proof (induction m arbitrary:a rule:poly_mapping_induct)
case (single v n)
show ?case unfolding reduce_nested_mpoly_def
apply (simp add: insertion_mult monom_pow)
using monom_pow[of 0 0 "f v" n] apply simp
using insertion_single[of f 0 0] by auto
next
case (sum m1 m2 k v)
then have "insertion f (insertion (λv. monom 0 (f v)) (monom m1 a * monom m2 1))
= insertion f (reduce_nested_mpoly (monom m1 a * monom m2 1))" unfolding reduce_nested_mpoly_prod insertion_mult by metis
then show ?case using mult_monom[of m1 a m2 1] by auto
qed
next
case (sum p1 p2 m a)
then show ?case by (simp add: reduce_nested_mpoly_sum insertion_add)
qed
definition extract_var::"'a::comm_ring_1 mpoly ⇒ nat ⇒ 'a::comm_ring_1 mpoly mpoly" where
"extract_var p v = (∑m. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
extract_var_finite_set:
assumes "{m'. coeff p m' ≠ 0} ⊆ S"
assumes "finite S"
shows "extract_var p v = (∑m∈S. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
proof-
{
fix m' assume "coeff p m' = 0"
then have "monom (remove_key v m') (monom (Poly_Mapping.single v (lookup m' v)) (coeff p m')) = 0"
using monom.abs_eq monom_zero single_zero by metis
}
then have 0:"{a. monom (remove_key v a) (monom (Poly_Mapping.single v (lookup a v)) (coeff p a)) ≠ 0} ⊆ S"
using ‹{m'. coeff p m' ≠ 0} ⊆ S› by fastforce
then show ?thesis
unfolding extract_var_def using Sum_any.expand_superset [OF ‹finite S› 0] by metis
qed
extract_var_non_zero_coeff: "extract_var p v = (∑m∈{m'. coeff p m' ≠ 0}. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
using extract_var_finite_set coeff_def finite_lookup order_refl by (metis (no_types, lifting) Collect_cong sum.cong)
extract_var_sum: "extract_var (p+p') v = extract_var p v + extract_var p' v"
proof -
define S where "S = {m. coeff p m ≠ 0} ∪ {m. coeff p' m ≠ 0} ∪ {m. coeff (p+p') m ≠ 0}"
have subsets:"{m. coeff p m ≠ 0} ⊆ S" "{m. coeff p' m ≠ 0} ⊆ S" "{m. coeff (p+p') m ≠ 0} ⊆ S"
unfolding S_def by auto
have "finite S" unfolding S_def using coeff_def finite_lookup
by (metis (mono_tags) Collect_disj_eq finite_Collect_disjI)
then show ?thesis unfolding
extract_var_finite_set[OF subsets(1) ‹finite S›]
extract_var_finite_set[OF subsets(2) ‹finite S›]
extract_var_finite_set[OF subsets(3) ‹finite S›]
coeff_add[symmetric] monom_add sum.distrib
by metis
qed
extract_var_monom:
shows "extract_var (monom m a) v = monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) a)"
proof (cases "a = 0")
assume "a ≠ 0"
have 0:"{m'. coeff (monom m a) m' ≠ 0} = {m}"
unfolding coeff_monom using ‹a ≠ 0› by auto
show ?thesis
unfolding extract_var_non_zero_coeff unfolding 0 unfolding coeff_monom
using sum.insert[OF finite.emptyI, unfolded sum.empty add.right_neutral] when_def
by auto
next
assume "a = 0"
have 0:"{m'. coeff (monom m a) m' ≠ 0} = {}"
unfolding coeff_monom using ‹a = 0› by auto
show ?thesis unfolding extract_var_non_zero_coeff 0
using ‹a = 0› monom.abs_eq monom_zero sum.empty single_zero by (metis (no_types, lifting))
qed
extract_var_monom_mult:
shows "extract_var (monom (m+m') (a*b)) v = extract_var (monom m a) v * extract_var (monom m' b) v"
unfolding extract_var_monom remove_key_add lookup_add single_add mult_monom by auto
extract_var_single: "extract_var (monom (Poly_Mapping.single v n) a) v = monom 0 (monom (Poly_Mapping.single v n) a)"
unfolding extract_var_monom by simp
extract_var_single':
assumes "v ≠ v'"
shows "extract_var (monom (Poly_Mapping.single v n) a) v' = monom (Poly_Mapping.single v n) (monom 0 a)"
unfolding extract_var_monom using assms by (metis add.right_neutral lookup_single_not_eq remove_key_sum single_zero)
reduce_nested_mpoly_extract_var:
fixes p::"'a::comm_ring_1 mpoly"
shows "reduce_nested_mpoly (extract_var p v) = p"
proof (induction p rule:mpoly_induct)
case (monom m a)
then show ?case
proof (induction m arbitrary:a rule:poly_mapping_induct)
case (single v' n)
show ?case
proof (cases "v' = v")
case True
then show ?thesis
by (metis (no_types, lifting) insertion_single mult.right_neutral power_0
reduce_nested_mpoly_def single_zero extract_var_single)
next
case False
then show ?thesis unfolding extract_var_single'[OF False] reduce_nested_mpoly_def insertion_single
by (simp add: monom_pow mult_monom)
qed
next
case (sum m m' v n a)
then show ?case
using extract_var_monom_mult[of m m' a 1] reduce_nested_mpoly_prod by (metis mult.right_neutral mult_monom)
qed
next
case (sum p1 p2 m a)
then show ?case unfolding extract_var_sum reduce_nested_mpoly_sum by auto
qed
vars_extract_var_subset: "vars (extract_var p v) ⊆ vars p"
proof
have "finite {m'. coeff p m' ≠ 0}" by (simp add: coeff_def)
fix x assume "x ∈ vars (extract_var p v)"
then have "x ∈ vars (∑m∈{m'. coeff p m' ≠ 0}. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
unfolding extract_var_non_zero_coeff by metis
then have "x ∈ (⋃m∈{m'. coeff p m' ≠ 0}. vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m))))"
using vars_setsum[OF ‹finite {m'. coeff p m' ≠ 0}›] by auto
then obtain m where "m∈{m'. coeff p m' ≠ 0}" "x ∈ vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
by blast
show "x ∈ vars p" by (metis (mono_tags, lifting) DiffD1 UN_I ‹m ∈ {m'. coeff p m' ≠ 0}›
‹x ∈ vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))›
coeff_keys mem_Collect_eq remove_key_keys subsetCE vars_def vars_monom_subset)
qed
v_not_in_vars_extract_var: "v ∉ vars (extract_var p v)"
proof -
have "finite {m'. coeff p m' ≠ 0}" by (simp add: coeff_def)
have "⋀m. m∈{m'. coeff p m' ≠ 0} ⟹ v ∉ vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
by (metis Diff_iff remove_key_keys singletonI subsetCE vars_monom_subset)
then have "v ∉ (⋃m∈{m'. coeff p m' ≠ 0}. vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m))))"
by simp
then show ?thesis
unfolding extract_var_non_zero_coeff using vars_setsum[OF ‹finite {m'. coeff p m' ≠ 0}›] by blast
qed
vars_coeff_extract_var: "vars (coeff (extract_var p v) j) ⊆ {v}"
proof (induction p rule:mpoly_induct)
case (monom m a)
then show ?case unfolding extract_var_monom coeff_monom vars_monom_single_cases
by (metis monom_zero single_zero vars_monom_single when_def)
next
case (sum p1 p2 m a)
then show ?case unfolding extract_var_sum coeff_add[symmetric]
by (metis (no_types, lifting) Un_insert_right insert_absorb2 subset_insertI2 subset_singletonD sup_bot.right_neutral vars_add)
qed
definition replace_coeff
where "replace_coeff f p = MPoly (Abs_poly_mapping (λm. f (lookup (mapping_of p) m)))"
lemma coeff_replace_coeff:
assumes "f 0 = 0"
shows "coeff (replace_coeff f p) m = f (coeff p m)"
proof -
have 0:"finite {m. f (lookup (mapping_of p) m) ≠ 0}"
unfolding coeff_def[symmetric] by (metis (mono_tags, lifting) Collect_mono assms(1) coeff_def finite_lookup finite_subset)+
then show ?thesis unfolding replace_coeff_def coeff_def using lookup_Abs_poly_mapping[OF 0]
by (metis (mono_tags, lifting) Quotient_mpoly Quotient_rep_abs_fold_unmap)
qed
lemma replace_coeff_monom:
assumes "f 0 = 0"
shows "replace_coeff f (monom m a) = monom m (f a)"
unfolding replace_coeff_def
unfolding mapping_of_inject[symmetric] lookup_inject[symmetric] apply (rule HOL.ext)
unfolding lookup_single mapping_of_monom fun_when[of f, OF ‹f 0 = 0›]
by (metis coeff_def coeff_monom lookup_single lookup_single_not_eq monom.abs_eq single.abs_eq)
lemma replace_coeff_add:
assumes "f 0 = 0"
assumes "⋀a b. f (a+b) = f a + f b"
shows "replace_coeff f (p1 + p2) = replace_coeff f p1 + replace_coeff f p2"
proof -
have "finite {m. f (lookup (mapping_of p1) m) ≠ 0}"
"finite {m. f (lookup (mapping_of p2) m) ≠ 0}"
unfolding coeff_def[symmetric] by (metis (mono_tags, lifting) Collect_mono assms(1) coeff_def finite_lookup finite_subset)+
then show ?thesis
unfolding replace_coeff_def plus_mpoly.rep_eq unfolding Poly_Mapping.plus_poly_mapping.rep_eq
unfolding assms(2) plus_mpoly.abs_eq using Poly_Mapping.plus_poly_mapping.abs_eq[unfolded eq_onp_def] by fastforce
qed
lemma insertion_replace_coeff:
fixes pp::"'a::comm_ring_1 mpoly mpoly"
shows "insertion f (replace_coeff (insertion f) pp) = insertion f (reduce_nested_mpoly pp)"
proof (induction pp rule:mpoly_induct)
case (monom m a)
then show ?case
proof (induction m arbitrary:a rule:poly_mapping_induct)
case (single v n)
show ?case unfolding reduce_nested_mpoly_def unfolding replace_coeff_monom[of "insertion f", OF insertion_zero]
insertion_single insertion_mult using insertion_single by (simp add: monom_pow)
next
case (sum m1 m2 k v)
have "replace_coeff (insertion f) (monom m1 a * monom m2 1) = replace_coeff (insertion f) (monom m1 a) * replace_coeff (insertion f) (monom m2 1)"
by (simp add: mult_monom replace_coeff_monom)
then have "insertion f (replace_coeff (insertion f) (monom m1 a * monom m2 1)) = insertion f (reduce_nested_mpoly (monom m1 a * monom m2 1))"
unfolding reduce_nested_mpoly_prod insertion_mult
by (simp add: insertion_mult sum.IH(1) sum.IH(2))
then show ?case using mult_monom[of m1 a m2 1] by auto
qed
next
case (sum p1 p2 m a)
then show ?case using reduce_nested_mpoly_sum insertion_add
replace_coeff_add[of "insertion f", OF insertion_zero insertion_add] by metis
qed
replace_coeff_extract_var_cong:
assumes "f v = g v"
shows "replace_coeff (insertion f) (extract_var p v) = replace_coeff (insertion g) (extract_var p v)"
by (induction p rule:mpoly_induct;simp add: assms extract_var_monom replace_coeff_monom
extract_var_sum insertion_add replace_coeff_add)
lemma vars_replace_coeff:
assumes "f 0 = 0"
shows "vars (replace_coeff f p) ⊆ vars p"
unfolding vars_def apply (rule subsetI) unfolding mem_simps(8) coeff_keys
using assms coeff_replace_coeff by (metis coeff_keys)
definition polyfun :: "nat set ⇒ ((nat ⇒ 'a::comm_semiring_1) ⇒ 'a) ⇒ bool"
where "polyfun N f = (∃p. vars p ⊆ N ∧ (∀x. insertion x p = f x))"
lemma polyfunI: "(⋀P. (⋀p. vars p ⊆ N ⟹ (⋀x. insertion x p = f x) ⟹ P) ⟹ P) ⟹ polyfun N f"
unfolding polyfun_def by metis
lemma polyfun_subset: "N⊆N' ⟹ polyfun N f ⟹ polyfun N' f"
unfolding polyfun_def by blast
lemma polyfun_const: "polyfun N (λ_. c)"
proof -
have "⋀x. insertion x (monom 0 c) = c" using insertion_single by (metis insertion_one monom_one mult.commute mult.right_neutral single_zero)
then show ?thesis unfolding polyfun_def by (metis (full_types) empty_iff keys_single single_zero subsetI subset_antisym vars_monom_subset)
qed
lemma polyfun_add:
assumes "polyfun N f" "polyfun N g"
shows "polyfun N (λx. f x + g x)"
proof -
obtain p1 p2 where "vars p1 ⊆ N" "∀x. insertion x p1 = f x"
"vars p2 ⊆ N" "∀x. insertion x p2 = g x"
using polyfun_def assms by metis
then have "vars (p1 + p2) ⊆ N" "∀x. insertion x (p1 + p2) = f x + g x"
using vars_add using Un_iff subsetCE subsetI apply blast
by (simp add: ‹∀x. insertion x p1 = f x› ‹∀x. insertion x p2 = g x› insertion_add)
then show ?thesis using polyfun_def by blast
qed
lemma polyfun_mult:
assumes "polyfun N f" "polyfun N g"
shows "polyfun N (λx. f x * g x)"
proof -
obtain p1 p2 where "vars p1 ⊆ N" "∀x. insertion x p1 = f x"
"vars p2 ⊆ N" "∀x. insertion x p2 = g x"
using polyfun_def assms by metis
then have "vars (p1 * p2) ⊆ N" "∀x. insertion x (p1 * p2) = f x * g x"
using vars_mult using Un_iff subsetCE subsetI apply blast
by (simp add: ‹∀x. insertion x p1 = f x› ‹∀x. insertion x p2 = g x› insertion_mult)
then show ?thesis using polyfun_def by blast
qed
lemma polyfun_Sum:
assumes "finite I"
assumes "⋀i. i∈I ⟹ polyfun N (f i)"
shows "polyfun N (λx. ∑i∈I. f i x)"
using assms
apply (induction I rule:finite_induct)
apply (simp add: polyfun_const)
using comm_monoid_add_class.sum.insert polyfun_add by fastforce
lemma polyfun_Prod:
assumes "finite I"
assumes "⋀i. i∈I ⟹ polyfun N (f i)"
shows "polyfun N (λx. ∏i∈I. f i x)"
using assms
apply (induction I rule:finite_induct)
apply (simp add: polyfun_const)
using comm_monoid_add_class.sum.insert polyfun_mult by fastforce
lemma polyfun_single:
assumes "i∈N"
shows "polyfun N (λx. x i)"
proof -
have "∀f. insertion f (monom (Poly_Mapping.single i 1) 1) = f i" using insertion_single by simp
then show ?thesis unfolding polyfun_def
using vars_monom_single[of i 1 1] One_nat_def assms singletonD subset_eq
by blast
qed
end
Theory Power_Products
section ‹Abstract Power-Products›
theory Power_Products
imports Complex_Main
"HOL-Library.Function_Algebras"
"HOL-Library.Countable"
"More_MPoly_Type"
"Utils"
Well_Quasi_Orders.Well_Quasi_Orders
begin
text ‹This theory formalizes the concept of "power-products". A power-product can be thought of as
the product of some indeterminates, such as $x$, $x^2\,y$, $x\,y^3\,z^7$, etc., without any
scalar coefficient.
The approach in this theory is to capture the notion of "power-product" (also called "monomial") as
type class. A canonical instance for power-product is the type @{typ "'var ⇒⇩0 nat"}, which is
interpreted as mapping from variables in the power-product to exponents.
A slightly unintuitive (but fitting better with the standard type class instantiations of
@{typ "'a ⇒⇩0 'b"}) approach is to write addition to denote "multiplication" of power products.
For example, $x^2y$ would be represented as a function ‹p = (X ↦ 2, Y ↦ 1)›, $xz$ as a
function ‹q = (X ↦ 1, Z ↦ 1)›. With the (pointwise) instantiation of addition of @{typ "'a ⇒⇩0 'b"},
we will write ‹p + q = (X ↦ 3, Y ↦ 1, Z ↦ 1)› for the product $x^2y \cdot xz = x^3yz$
›
subsection ‹Constant @{term Keys}›
text ‹Legacy:›
lemmas keys_eq_empty_iff = keys_eq_empty
definition Keys :: "('a ⇒⇩0 'b::zero) set ⇒ 'a set"
where "Keys F = ⋃(keys ` F)"
lemma in_Keys: "s ∈ Keys F ⟷ (∃f∈F. s ∈ keys f)"
unfolding Keys_def by simp
lemma in_KeysI:
assumes "s ∈ keys f" and "f ∈ F"
shows "s ∈ Keys F"
unfolding in_Keys using assms ..
lemma in_KeysE:
assumes "s ∈ Keys F"
obtains f where "s ∈ keys f" and "f ∈ F"
using assms unfolding in_Keys ..
lemma Keys_mono:
assumes "A ⊆ B"
shows "Keys A ⊆ Keys B"
using assms by (auto simp add: Keys_def)
lemma Keys_insert: "Keys (insert a A) = keys a ∪ Keys A"
by (simp add: Keys_def)
lemma Keys_Un: "Keys (A ∪ B) = Keys A ∪ Keys B"
by (simp add: Keys_def)
lemma finite_Keys:
assumes "finite A"
shows "finite (Keys A)"
unfolding Keys_def by (rule, fact assms, rule finite_keys)
lemma Keys_not_empty:
assumes "a ∈ A" and "a ≠ 0"
shows "Keys A ≠ {}"
proof
assume "Keys A = {}"
from ‹a ≠ 0› have "keys a ≠ {}" using aux by fastforce
then obtain s where "s ∈ keys a" by blast
from this assms(1) have "s ∈ Keys A" by (rule in_KeysI)
with ‹Keys A = {}› show False by simp
qed
lemma Keys_empty [simp]: "Keys {} = {}"
by (simp add: Keys_def)
lemma Keys_zero [simp]: "Keys {0} = {}"
by (simp add: Keys_def)
lemma keys_subset_Keys:
assumes "f ∈ F"
shows "keys f ⊆ Keys F"
using in_KeysI[OF _ assms] by auto
lemma Keys_minus: "Keys (A - B) ⊆ Keys A"
by (auto simp add: Keys_def)
lemma Keys_minus_zero: "Keys (A - {0}) = Keys A"
proof (cases "0 ∈ A")
case True
hence "(A - {0}) ∪ {0} = A" by auto
hence "Keys A = Keys ((A - {0}) ∪ {0})" by simp
also have "... = Keys (A - {0}) ∪ Keys {0::('a ⇒⇩0 'b)}" by (fact Keys_Un)
also have "... = Keys (A - {0})" by simp
finally show ?thesis by simp
next
case False
hence "A - {0} = A" by simp
thus ?thesis by simp
qed
subsection ‹Constant @{term except}›
definition except_fun :: "('a ⇒ 'b) ⇒ 'a set ⇒ ('a ⇒ 'b::zero)"
where "except_fun f S = (λx. (f x when x ∉ S))"
lift_definition except :: "('a ⇒⇩0 'b) ⇒ 'a set ⇒ ('a ⇒⇩0 'b::zero)" is except_fun
proof -
fix p::"'a ⇒ 'b" and S::"'a set"
assume "finite {t. p t ≠ 0}"
show "finite {t. except_fun p S t ≠ 0}"
proof (rule finite_subset[of _ "{t. p t ≠ 0}"], rule)
fix u
assume "u ∈ {t. except_fun p S t ≠ 0}"
hence "p u ≠ 0" by (simp add: except_fun_def)
thus "u ∈ {t. p t ≠ 0}" by simp
qed fact
qed
lemma lookup_except_when: "lookup (except p S) = (λt. lookup p t when t ∉ S)"
by (auto simp: except.rep_eq except_fun_def)
lemma lookup_except: "lookup (except p S) = (λt. if t ∈ S then 0 else lookup p t)"
by (rule ext) (simp add: lookup_except_when)
lemma lookup_except_singleton: "lookup (except p {t}) t = 0"
by (simp add: lookup_except)
lemma except_zero [simp]: "except 0 S = 0"
by (rule poly_mapping_eqI) (simp add: lookup_except)
lemma lookup_except_eq_idI:
assumes "t ∉ S"
shows "lookup (except p S) t = lookup p t"
using assms by (simp add: lookup_except)
lemma lookup_except_eq_zeroI:
assumes "t ∈ S"
shows "lookup (except p S) t = 0"
using assms by (simp add: lookup_except)
lemma except_empty [simp]: "except p {} = p"
by (rule poly_mapping_eqI) (simp add: lookup_except)
lemma except_eq_zeroI:
assumes "keys p ⊆ S"
shows "except p S = 0"
proof (rule poly_mapping_eqI, simp)
fix t
show "lookup (except p S) t = 0"
proof (cases "t ∈ S")
case True
thus ?thesis by (rule lookup_except_eq_zeroI)
next
case False then show ?thesis
by (metis assms in_keys_iff lookup_except_eq_idI subset_eq)
qed
qed
lemma except_eq_zeroE:
assumes "except p S = 0"
shows "keys p ⊆ S"
by (metis assms aux in_keys_iff lookup_except_eq_idI subset_iff)
lemma except_eq_zero_iff: "except p S = 0 ⟷ keys p ⊆ S"
by (rule, elim except_eq_zeroE, elim except_eq_zeroI)
lemma except_keys [simp]: "except p (keys p) = 0"
by (rule except_eq_zeroI, rule subset_refl)
lemma plus_except: "p = Poly_Mapping.single t (lookup p t) + except p {t}"
by (rule poly_mapping_eqI, simp add: lookup_add lookup_single lookup_except when_def split: if_split)
lemma keys_except: "keys (except p S) = keys p - S"
by (transfer, auto simp: except_fun_def)
lemma except_single: "except (Poly_Mapping.single u c) S = (Poly_Mapping.single u c when u ∉ S)"
by (rule poly_mapping_eqI) (simp add: lookup_except lookup_single when_def)
lemma except_plus: "except (p + q) S = except p S + except q S"
by (rule poly_mapping_eqI) (simp add: lookup_except lookup_add)
lemma except_minus: "except (p - q) S = except p S - except q S"
by (rule poly_mapping_eqI) (simp add: lookup_except lookup_minus)
lemma except_uminus: "except (- p) S = - except p S"
by (rule poly_mapping_eqI) (simp add: lookup_except)
lemma except_except: "except (except p S) T = except p (S ∪ T)"
by (rule poly_mapping_eqI) (simp add: lookup_except)
lemma poly_mapping_keys_eqI:
assumes a1: "keys p = keys q" and a2: "⋀t. t ∈ keys p ⟹ lookup p t = lookup q t"
shows "p = q"
proof (rule poly_mapping_eqI)
fix t
show "lookup p t = lookup q t"
proof (cases "t ∈ keys p")
case True
thus ?thesis by (rule a2)
next
case False
moreover from this have "t ∉ keys q" unfolding a1 .
ultimately have "lookup p t = 0" and "lookup q t = 0" unfolding in_keys_iff by simp_all
thus ?thesis by simp
qed
qed
lemma except_id_iff: "except p S = p ⟷ keys p ∩ S = {}"
by (metis Diff_Diff_Int Diff_eq_empty_iff Diff_triv inf_le2 keys_except lookup_except_eq_idI
lookup_except_eq_zeroI not_in_keys_iff_lookup_eq_zero poly_mapping_keys_eqI)
lemma keys_subset_wf:
"wfP (λp q::('a, 'b::zero) poly_mapping. keys p ⊂ keys q)"
unfolding wfP_def
proof (intro wfI_min)
fix x::"('a, 'b) poly_mapping" and Q
assume x_in: "x ∈ Q"
let ?Q0 = "card ` keys ` Q"
from x_in have "card (keys x) ∈ ?Q0" by simp
from wfE_min[OF wf this] obtain z0
where z0_in: "z0 ∈ ?Q0" and z0_min: "⋀y. (y, z0) ∈ {(x, y). x < y} ⟹ y ∉ ?Q0" by auto
from z0_in obtain z where z0_def: "z0 = card (keys z)" and "z ∈ Q" by auto
show "∃z∈Q. ∀y. (y, z) ∈ {(p, q). keys p ⊂ keys q} ⟶ y ∉ Q"
proof (intro bexI[of _ z], rule, rule)
fix y::"('a, 'b) poly_mapping"
let ?y0 = "card (keys y)"
assume "(y, z) ∈ {(p, q). keys p ⊂ keys q}"
hence "keys y ⊂ keys z" by simp
hence "?y0 < z0" unfolding z0_def by (simp add: psubset_card_mono)
hence "(?y0, z0) ∈ {(x, y). x < y}" by simp
from z0_min[OF this] show "y ∉ Q" by auto
qed (fact)
qed
lemma poly_mapping_except_induct:
assumes base: "P 0" and ind: "⋀p t. p ≠ 0 ⟹ t ∈ keys p ⟹ P (except p {t}) ⟹ P p"
shows "P p"
proof (induct rule: wfP_induct[OF keys_subset_wf])
fix p::"('a, 'b) poly_mapping"
assume "∀q. keys q ⊂ keys p ⟶ P q"
hence IH: "⋀q. keys q ⊂ keys p ⟹ P q" by simp
show "P p"
proof (cases "p = 0")
case True
thus ?thesis using base by simp
next
case False
hence "keys p ≠ {}" by simp
then obtain t where "t ∈ keys p" by blast
show ?thesis
proof (rule ind, fact, fact, rule IH, simp only: keys_except, rule, rule Diff_subset, rule)
assume "keys p - {t} = keys p"
hence "t ∉ keys p" by blast
from this ‹t ∈ keys p› show False ..
qed
qed
qed
lemma poly_mapping_except_induct':
assumes "⋀p. (⋀t. t ∈ keys p ⟹ P (except p {t})) ⟹ P p"
shows "P p"
proof (induct "card (keys p)" arbitrary: p)
case 0
with finite_keys[of p] have "keys p = {}" by simp
show ?case by (rule assms, simp add: ‹keys p = {}›)
next
case step: (Suc n)
show ?case
proof (rule assms)
fix t
assume "t ∈ keys p"
show "P (except p {t})"
proof (rule step(1), simp add: keys_except)
from step(2) ‹t ∈ keys p› finite_keys[of p] show "n = card (keys p - {t})" by simp
qed
qed
qed
lemma poly_mapping_plus_induct:
assumes "P 0" and "⋀p c t. c ≠ 0 ⟹ t ∉ keys p ⟹ P p ⟹ P (Poly_Mapping.single t c + p)"
shows "P p"
proof (induct "card (keys p)" arbitrary: p)
case 0
with finite_keys[of p] have "keys p = {}" by simp
hence "p = 0" by simp
with assms(1) show ?case by simp
next
case step: (Suc n)
from step(2) obtain t where t: "t ∈ keys p" by (metis card_eq_SucD insert_iff)
define c where "c = lookup p t"
define q where "q = except p {t}"
have *: "p = Poly_Mapping.single t c + q"
by (rule poly_mapping_eqI, simp add: lookup_add lookup_single Poly_Mapping.when_def, intro conjI impI,
simp add: q_def lookup_except c_def, simp add: q_def lookup_except_eq_idI)
show ?case
proof (simp only: *, rule assms(2))
from t show "c ≠ 0"
using c_def by auto
next
show "t ∉ keys q" by (simp add: q_def keys_except)
next
show "P q"
proof (rule step(1))
from step(2) ‹t ∈ keys p› show "n = card (keys q)" unfolding q_def keys_except
by (metis Suc_inject card.remove finite_keys)
qed
qed
qed
lemma except_Diff_singleton: "except p (keys p - {t}) = Poly_Mapping.single t (lookup p t)"
by (rule poly_mapping_eqI) (simp add: lookup_single in_keys_iff lookup_except when_def)
lemma except_Un_plus_Int: "except p (U ∪ V) + except p (U ∩ V) = except p U + except p V"
by (rule poly_mapping_eqI) (simp add: lookup_except lookup_add)
corollary except_Int:
assumes "keys p ⊆ U ∪ V"
shows "except p (U ∩ V) = except p U + except p V"
proof -
from assms have "except p (U ∪ V) = 0" by (rule except_eq_zeroI)
hence "except p (U ∩ V) = except p (U ∪ V) + except p (U ∩ V)" by simp
also have "… = except p U + except p V" by (fact except_Un_plus_Int)
finally show ?thesis .
qed
lemma except_keys_Int [simp]: "except p (keys p ∩ U) = except p U"
by (rule poly_mapping_eqI) (simp add: in_keys_iff lookup_except)
lemma except_Int_keys [simp]: "except p (U ∩ keys p) = except p U"
by (simp only: Int_commute[of U] except_keys_Int)
lemma except_keys_Diff: "except p (keys p - U) = except p (- U)"
proof -
have "except p (keys p - U) = except p (keys p ∩ (- U))" by (simp only: Diff_eq)
also have "… = except p (- U)" by simp
finally show ?thesis .
qed
lemma except_decomp: "p = except p U + except p (- U)"
by (rule poly_mapping_eqI) (simp add: lookup_except lookup_add)
corollary except_Compl: "except p (- U) = p - except p U"
by (metis add_diff_cancel_left' except_decomp)
subsection ‹'Divisibility' on Additive Structures›
context plus begin
definition adds :: "'a ⇒ 'a ⇒ bool" (infix "adds" 50)
where "b adds a ⟷ (∃k. a = b + k)"
lemma addsI [intro?]: "a = b + k ⟹ b adds a"
unfolding adds_def ..
lemma addsE [elim?]: "b adds a ⟹ (⋀k. a = b + k ⟹ P) ⟹ P"
unfolding adds_def by blast
end
context comm_monoid_add
begin
lemma adds_refl [simp]: "a adds a"
proof
show "a = a + 0" by simp
qed
lemma adds_trans [trans]:
assumes "a adds b" and "b adds c"
shows "a adds c"
proof -
from assms obtain v where "b = a + v"
by (auto elim!: addsE)
moreover from assms obtain w where "c = b + w"
by (auto elim!: addsE)
ultimately have "c = a + (v + w)"
by (simp add: add.assoc)
then show ?thesis ..
qed
lemma subset_divisors_adds: "{c. c adds a} ⊆ {c. c adds b} ⟷ a adds b"
by (auto simp add: subset_iff intro: adds_trans)
lemma strict_subset_divisors_adds: "{c. c adds a} ⊂ {c. c adds b} ⟷ a adds b ∧ ¬ b adds a"
by (auto simp add: subset_iff intro: adds_trans)
lemma zero_adds [simp]: "0 adds a"
by (auto intro!: addsI)
lemma adds_plus_right [simp]: "a adds c ⟹ a adds (b + c)"
by (auto intro!: add.left_commute addsI elim!: addsE)
lemma adds_plus_left [simp]: "a adds b ⟹ a adds (b + c)"
using adds_plus_right [of a b c] by (simp add: ac_simps)
lemma adds_triv_right [simp]: "a adds b + a"
by (rule adds_plus_right) (rule adds_refl)
lemma adds_triv_left [simp]: "a adds a + b"
by (rule adds_plus_left) (rule adds_refl)
lemma plus_adds_mono:
assumes "a adds b"
and "c adds d"
shows "a + c adds b + d"
proof -
from ‹a adds b› obtain b' where "b = a + b'" ..
moreover from ‹c adds d› obtain d' where "d = c + d'" ..
ultimately have "b + d = (a + c) + (b' + d')"
by (simp add: ac_simps)
then show ?thesis ..
qed
lemma plus_adds_left: "a + b adds c ⟹ a adds c"
by (simp add: adds_def add.assoc) blast
lemma plus_adds_right: "a + b adds c ⟹ b adds c"
using plus_adds_left [of b a c] by (simp add: ac_simps)
end
class ninv_comm_monoid_add = comm_monoid_add +
assumes plus_eq_zero: "s + t = 0 ⟹ s = 0"
begin
lemma plus_eq_zero_2: "t = 0" if "s + t = 0"
using that
by (simp only: add_commute[of s t] plus_eq_zero)
lemma adds_zero: "s adds 0 ⟷ (s = 0)"
proof
assume "s adds 0"
from this obtain k where "0 = s + k" unfolding adds_def ..
from this plus_eq_zero[of s k] show "s = 0"
by blast
next
assume "s = 0"
thus "s adds 0" by simp
qed
end
context canonically_ordered_monoid_add
begin
subclass ninv_comm_monoid_add by (standard, simp)
end
class comm_powerprod = cancel_comm_monoid_add
begin
lemma adds_canc: "s + u adds t + u ⟷ s adds t" for s t u::'a
unfolding adds_def
apply auto
apply (metis local.add.left_commute local.add_diff_cancel_left' local.add_diff_cancel_right')
using add_assoc add_commute by auto
lemma adds_canc_2: "u + s adds u + t ⟷ s adds t"
by (simp add: adds_canc ac_simps)
lemma add_minus_2: "(s + t) - s = t"
by simp
lemma adds_minus:
assumes "s adds t"
shows "(t - s) + s = t"
proof -
from assms adds_def[of s t] obtain u where u: "t = u + s" by (auto simp: ac_simps)
then have "t - s = u"
by simp
thus ?thesis using u by simp
qed
lemma plus_adds_0:
assumes "(s + t) adds u"
shows "s adds (u - t)"
proof -
from assms have "(s + t) adds ((u - t) + t)" using adds_minus local.plus_adds_right by presburger
thus ?thesis using adds_canc[of s t "u - t"] by simp
qed
lemma plus_adds_2:
assumes "t adds u" and "s adds (u - t)"
shows "(s + t) adds u"
by (metis adds_canc adds_minus assms)
lemma plus_adds:
shows "(s + t) adds u ⟷ (t adds u ∧ s adds (u - t))"
proof
assume a1: "(s + t) adds u"
show "t adds u ∧ s adds (u - t)"
proof
from plus_adds_right[OF a1] show "t adds u" .
next
from plus_adds_0[OF a1] show "s adds (u - t)" .
qed
next
assume "t adds u ∧ s adds (u - t)"
hence "t adds u" and "s adds (u - t)" by auto
from plus_adds_2[OF ‹t adds u› ‹s adds (u - t)›] show "(s + t) adds u" .
qed
lemma minus_plus:
assumes "s adds t"
shows "(t - s) + u = (t + u) - s"
proof -
from assms obtain k where k: "t = s + k" unfolding adds_def ..
hence "t - s = k" by simp
also from k have "(t + u) - s = k + u"
by (simp add: add_assoc)
finally show ?thesis by simp
qed
lemma minus_plus_minus:
assumes "s adds t" and "u adds v"
shows "(t - s) + (v - u) = (t + v) - (s + u)"
using add_commute assms(1) assms(2) diff_diff_add minus_plus by auto
lemma minus_plus_minus_cancel:
assumes "u adds t" and "s adds u"
shows "(t - u) + (u - s) = t - s"
by (metis assms(1) assms(2) local.add_diff_cancel_left' local.add_diff_cancel_right local.addsE minus_plus)
end
text ‹Instances of class ‹lcs_powerprod› are types of commutative power-products admitting
(not necessarily unique) least common sums (inspired from least common multiplies).
Note that if the components of indeterminates are arbitrary integers (as for instance in Laurent
polynomials), then no unique lcss exist.›
class lcs_powerprod = comm_powerprod +
fixes lcs::"'a ⇒ 'a ⇒ 'a"
assumes adds_lcs: "s adds (lcs s t)"
assumes lcs_adds: "s adds u ⟹ t adds u ⟹ (lcs s t) adds u"
assumes lcs_comm: "lcs s t = lcs t s"
begin
lemma adds_lcs_2: "t adds (lcs s t)"
by (simp only: lcs_comm[of s t], rule adds_lcs)
lemma lcs_adds_plus: "lcs s t adds s + t" by (simp add: lcs_adds)
text ‹"gcs" stands for "greatest common summand".›
definition gcs :: "'a ⇒ 'a ⇒ 'a" where "gcs s t = (s + t) - (lcs s t)"
lemma gcs_plus_lcs: "(gcs s t) + (lcs s t) = s + t"
unfolding gcs_def by (rule adds_minus, fact lcs_adds_plus)
lemma gcs_adds: "(gcs s t) adds s"
proof -
have "t adds (lcs s t)" (is "t adds ?l") unfolding lcs_comm[of s t] by (fact adds_lcs)
then obtain u where eq1: "?l = t + u" unfolding adds_def ..
from lcs_adds_plus[of s t] obtain v where eq2: "s + t = ?l + v" unfolding adds_def ..
hence "t + s = t + (u + v)" unfolding eq1 by (simp add: ac_simps)
hence s: "s = u + v" unfolding add_left_cancel .
show ?thesis unfolding eq2 gcs_def unfolding s by simp
qed
lemma gcs_comm: "gcs s t = gcs t s" unfolding gcs_def by (simp add: lcs_comm ac_simps)
lemma gcs_adds_2: "(gcs s t) adds t"
by (simp only: gcs_comm[of s t], rule gcs_adds)
end
class ulcs_powerprod = lcs_powerprod + ninv_comm_monoid_add
begin
lemma adds_antisym:
assumes "s adds t" "t adds s"
shows "s = t"
proof -
from ‹s adds t› obtain u where u_def: "t = s + u" unfolding adds_def ..
from ‹t adds s› obtain v where v_def: "s = t + v" unfolding adds_def ..
from u_def v_def have "s = (s + u) + v" by (simp add: ac_simps)
hence "s + 0 = s + (u + v)" by (simp add: ac_simps)
hence "u + v = 0" by simp
hence "u = 0" using plus_eq_zero[of u v] by simp
thus ?thesis using u_def by simp
qed
lemma lcs_unique:
assumes "s adds l" and "t adds l" and *: "⋀u. s adds u ⟹ t adds u ⟹ l adds u"
shows "l = lcs s t"
by (rule adds_antisym, rule *, fact adds_lcs, fact adds_lcs_2, rule lcs_adds, fact+)
lemma lcs_zero: "lcs 0 t = t"
by (rule lcs_unique[symmetric], fact zero_adds, fact adds_refl)
lemma lcs_plus_left: "lcs (u + s) (u + t) = u + lcs s t"
proof (rule lcs_unique[symmetric], simp_all only: adds_canc_2, fact adds_lcs, fact adds_lcs_2,
simp add: add.commute[of u] plus_adds)
fix v
assume "u adds v ∧ s adds v - u"
hence "s adds v - u" ..
assume "t adds v - u"
with ‹s adds v - u› show "lcs s t adds v - u" by (rule lcs_adds)
qed
lemma lcs_plus_right: "lcs (s + u) (t + u) = (lcs s t) + u"
using lcs_plus_left[of u s t] by (simp add: ac_simps)
lemma adds_gcs:
assumes "u adds s" and "u adds t"
shows "u adds (gcs s t)"
proof -
from assms have "s + u adds s + t" and "t + u adds t + s"
by (simp_all add: plus_adds_mono)
hence "lcs (s + u) (t + u) adds s + t"
by (auto intro: lcs_adds simp add: ac_simps)
hence "u + (lcs s t) adds s + t" unfolding lcs_plus_right by (simp add: ac_simps)
hence "u adds (s + t) - (lcs s t)" unfolding plus_adds ..
thus ?thesis unfolding gcs_def .
qed
lemma gcs_unique:
assumes "g adds s" and "g adds t" and *: "⋀u. u adds s ⟹ u adds t ⟹ u adds g"
shows "g = gcs s t"
by (rule adds_antisym, rule adds_gcs, fact, fact, rule *, fact gcs_adds, fact gcs_adds_2)
lemma gcs_plus_left: "gcs (u + s) (u + t) = u + gcs s t"
proof -
have "u + s + (u + t) - (u + lcs s t) = u + s + (u + t) - u - lcs s t" by (simp only: diff_diff_add)
also have "... = u + s + t + (u - u) - lcs s t" by (simp add: add.left_commute)
also have "... = u + s + t - lcs s t" by simp
also have "... = u + (s + t - lcs s t)"
using add_assoc add_commute local.lcs_adds_plus local.minus_plus by auto
finally show ?thesis unfolding gcs_def lcs_plus_left .
qed
lemma gcs_plus_right: "gcs (s + u) (t + u) = (gcs s t) + u"
using gcs_plus_left[of u s t] by (simp add: ac_simps)
lemma lcs_same [simp]: "lcs s s = s"
proof -
have "lcs s s adds s" by (rule lcs_adds, simp_all)
moreover have "s adds lcs s s" by (rule adds_lcs)
ultimately show ?thesis by (rule adds_antisym)
qed
lemma gcs_same [simp]: "gcs s s = s"
proof -
have "gcs s s adds s" by (rule gcs_adds)
moreover have "s adds gcs s s" by (rule adds_gcs, simp_all)
ultimately show ?thesis by (rule adds_antisym)
qed
end
subsection ‹Dickson Classes›
definition (in plus) dickson_grading :: "('a ⇒ nat) ⇒ bool"
where "dickson_grading d ⟷
((∀s t. d (s + t) = max (d s) (d t)) ∧ (∀n::nat. almost_full_on (adds) {x. d x ≤ n}))"
definition dgrad_set :: "('a ⇒ nat) ⇒ nat ⇒ 'a set"
where "dgrad_set d m = {t. d t ≤ m}"
definition dgrad_set_le :: "('a ⇒ nat) ⇒ ('a set) ⇒ ('a set) ⇒ bool"
where "dgrad_set_le d S T ⟷ (∀s∈S. ∃t∈T. d s ≤ d t)"
lemma dickson_gradingI:
assumes "⋀s t. d (s + t) = max (d s) (d t)"
assumes "⋀n::nat. almost_full_on (adds) {x. d x ≤ n}"
shows "dickson_grading d"
unfolding dickson_grading_def using assms by blast
lemma dickson_gradingD1: "dickson_grading d ⟹ d (s + t) = max (d s) (d t)"
by (auto simp add: dickson_grading_def)
lemma dickson_gradingD2: "dickson_grading d ⟹ almost_full_on (adds) {x. d x ≤ n}"
by (auto simp add: dickson_grading_def)
lemma dickson_gradingD2':
assumes "dickson_grading (d::'a::comm_monoid_add ⇒ nat)"
shows "wqo_on (adds) {x. d x ≤ n}"
proof (intro wqo_onI transp_onI)
fix x y z :: 'a
assume "x adds y" and "y adds z"
thus "x adds z" by (rule adds_trans)
next
from assms show "almost_full_on (adds) {x. d x ≤ n}" by (rule dickson_gradingD2)
qed
lemma dickson_gradingE:
assumes "dickson_grading d" and "⋀i::nat. d ((seq::nat ⇒ 'a::plus) i) ≤ n"
obtains i j where "i < j" and "seq i adds seq j"
proof -
from assms(1) have "almost_full_on (adds) {x. d x ≤ n}" by (rule dickson_gradingD2)
moreover from assms(2) have "⋀i. seq i ∈ {x. d x ≤ n}" by simp
ultimately obtain i j where "i < j" and "seq i adds seq j" by (rule almost_full_onD)
thus ?thesis ..
qed
lemma dickson_grading_adds_imp_le:
assumes "dickson_grading d" and "s adds t"
shows "d s ≤ d t"
proof -
from assms(2) obtain u where "t = s + u" ..
hence "d t = max (d s) (d u)" by (simp only: dickson_gradingD1[OF assms(1)])
thus ?thesis by simp
qed
lemma dickson_grading_minus:
assumes "dickson_grading d" and "s adds (t::'a::cancel_ab_semigroup_add)"
shows "d (t - s) ≤ d t"
proof -
from assms(2) obtain u where "t = s + u" ..
hence "t - s = u" by simp
from assms(1) have "d t = ord_class.max (d s) (d u)" unfolding ‹t = s + u› by (rule dickson_gradingD1)
thus ?thesis by (simp add: ‹t - s = u›)
qed
lemma dickson_grading_lcs:
assumes "dickson_grading d"
shows "d (lcs s t) ≤ max (d s) (d t)"
proof -
from assms have "d (lcs s t) ≤ d (s + t)" by (rule dickson_grading_adds_imp_le, intro lcs_adds_plus)
thus ?thesis by (simp only: dickson_gradingD1[OF assms])
qed
lemma dickson_grading_lcs_minus:
assumes "dickson_grading d"
shows "d (lcs s t - s) ≤ max (d s) (d t)"
proof -
from assms have "d (lcs s t - s) ≤ d (lcs s t)" by (rule dickson_grading_minus, intro adds_lcs)
also from assms have "... ≤ max (d s) (d t)" by (rule dickson_grading_lcs)
finally show ?thesis .
qed
lemma dgrad_set_leI:
assumes "⋀s. s ∈ S ⟹ ∃t∈T. d s ≤ d t"
shows "dgrad_set_le d S T"
using assms by (auto simp: dgrad_set_le_def)
lemma dgrad_set_leE:
assumes "dgrad_set_le d S T" and "s ∈ S"
obtains t where "t ∈ T" and "d s ≤ d t"
using assms by (auto simp: dgrad_set_le_def)
lemma dgrad_set_exhaust_expl:
assumes "finite F"
shows "F ⊆ dgrad_set d (Max (d ` F))"
proof
fix f
assume "f ∈ F"
hence "d f ∈ d ` F" by simp
with _ have "d f ≤ Max (d ` F)"
proof (rule Max_ge)
from assms show "finite (d ` F)" by auto
qed
hence "dgrad_set d (d f) ⊆ dgrad_set d (Max (d ` F))" by (auto simp: dgrad_set_def)
moreover have "f ∈ dgrad_set d (d f)" by (simp add: dgrad_set_def)
ultimately show "f ∈ dgrad_set d (Max (d ` F))" ..
qed
lemma dgrad_set_exhaust:
assumes "finite F"
obtains m where "F ⊆ dgrad_set d m"
proof
from assms show "F ⊆ dgrad_set d (Max (d ` F))" by (rule dgrad_set_exhaust_expl)
qed
lemma dgrad_set_le_trans [trans]:
assumes "dgrad_set_le d S T" and "dgrad_set_le d T U"
shows "dgrad_set_le d S U"
unfolding dgrad_set_le_def
proof
fix s
assume "s ∈ S"
with assms(1) obtain t where "t ∈ T" and 1: "d s ≤ d t" by (auto simp add: dgrad_set_le_def)
from assms(2) this(1) obtain u where "u ∈ U" and 2: "d t ≤ d u" by (auto simp add: dgrad_set_le_def)
from this(1) show "∃u∈U. d s ≤ d u"
proof
from 1 2 show "d s ≤ d u" by (rule le_trans)
qed
qed
lemma dgrad_set_le_Un: "dgrad_set_le d (S ∪ T) U ⟷ (dgrad_set_le d S U ∧ dgrad_set_le d T U)"
by (auto simp add: dgrad_set_le_def)
lemma dgrad_set_le_subset:
assumes "S ⊆ T"
shows "dgrad_set_le d S T"
unfolding dgrad_set_le_def using assms by blast
lemma dgrad_set_le_refl: "dgrad_set_le d S S"
by (rule dgrad_set_le_subset, fact subset_refl)
lemma dgrad_set_le_dgrad_set:
assumes "dgrad_set_le d F G" and "G ⊆ dgrad_set d m"
shows "F ⊆ dgrad_set d m"
proof
fix f
assume "f ∈ F"
with assms(1) obtain g where "g ∈ G" and *: "d f ≤ d g" by (auto simp add: dgrad_set_le_def)
from assms(2) this(1) have "g ∈ dgrad_set d m" ..
hence "d g ≤ m" by (simp add: dgrad_set_def)
with * have "d f ≤ m" by (rule le_trans)
thus "f ∈ dgrad_set d m" by (simp add: dgrad_set_def)
qed
lemma dgrad_set_dgrad: "p ∈ dgrad_set d (d p)"
by (simp add: dgrad_set_def)
lemma dgrad_setI [intro]:
assumes "d t ≤ m"
shows "t ∈ dgrad_set d m"
using assms by (auto simp: dgrad_set_def)
lemma dgrad_setD:
assumes "t ∈ dgrad_set d m"
shows "d t ≤ m"
using assms by (simp add: dgrad_set_def)
lemma dgrad_set_zero [simp]: "dgrad_set (λ_. 0) m = UNIV"
by auto
lemma subset_dgrad_set_zero: "F ⊆ dgrad_set (λ_. 0) m"
by simp
lemma dgrad_set_subset:
assumes "m ≤ n"
shows "dgrad_set d m ⊆ dgrad_set d n"
using assms by (auto simp: dgrad_set_def)
lemma dgrad_set_closed_plus:
assumes "dickson_grading d" and "s ∈ dgrad_set d m" and "t ∈ dgrad_set d m"
shows "s + t ∈ dgrad_set d m"
proof -
from assms(1) have "d (s + t) = ord_class.max (d s) (d t)" by (rule dickson_gradingD1)
also from assms(2, 3) have "... ≤ m" by (simp add: dgrad_set_def)
finally show ?thesis by (simp add: dgrad_set_def)
qed
lemma dgrad_set_closed_minus:
assumes "dickson_grading d" and "s ∈ dgrad_set d m" and "t adds (s::'a::cancel_ab_semigroup_add)"
shows "s - t ∈ dgrad_set d m"
proof -
from assms(1, 3) have "d (s - t) ≤ d s" by (rule dickson_grading_minus)
also from assms(2) have "... ≤ m" by (simp add: dgrad_set_def)
finally show ?thesis by (simp add: dgrad_set_def)
qed
lemma dgrad_set_closed_lcs:
assumes "dickson_grading d" and "s ∈ dgrad_set d m" and "t ∈ dgrad_set d m"
shows "lcs s t ∈ dgrad_set d m"
proof -
from assms(1) have "d (lcs s t) ≤ ord_class.max (d s) (d t)" by (rule dickson_grading_lcs)
also from assms(2, 3) have "... ≤ m" by (simp add: dgrad_set_def)
finally show ?thesis by (simp add: dgrad_set_def)
qed
lemma dickson_gradingD_dgrad_set: "dickson_grading d ⟹ almost_full_on (adds) (dgrad_set d m)"
by (auto dest: dickson_gradingD2 simp: dgrad_set_def)
lemma ex_finite_adds:
assumes "dickson_grading d" and "S ⊆ dgrad_set d m"
obtains T where "finite T" and "T ⊆ S" and "⋀s. s ∈ S ⟹ (∃t∈T. t adds (s::'a::cancel_comm_monoid_add))"
proof -
have "reflp ((adds)::'a ⇒ _)" by (simp add: reflp_def)
moreover from assms(2) have "almost_full_on (adds) S"
proof (rule almost_full_on_subset)
from assms(1) show "almost_full_on (adds) (dgrad_set d m)" by (rule dickson_gradingD_dgrad_set)
qed
ultimately obtain T where "finite T" and "T ⊆ S" and "⋀s. s ∈ S ⟹ (∃t∈T. t adds s)"
by (rule almost_full_on_finite_subsetE, blast)
thus ?thesis ..
qed
class graded_dickson_powerprod = ulcs_powerprod +
assumes ex_dgrad: "∃d::'a ⇒ nat. dickson_grading d"
begin
definition dgrad_dummy where "dgrad_dummy = (SOME d. dickson_grading d)"
lemma dickson_grading_dgrad_dummy: "dickson_grading dgrad_dummy"
unfolding dgrad_dummy_def using ex_dgrad by (rule someI_ex)
end
class dickson_powerprod = ulcs_powerprod +
assumes dickson: "almost_full_on (adds) UNIV"
begin
lemma dickson_grading_zero: "dickson_grading (λ_::'a. 0)"
by (simp add: dickson_grading_def dickson)
subclass graded_dickson_powerprod by (standard, rule, fact dickson_grading_zero)
end
text ‹Class @{class graded_dickson_powerprod} is a slightly artificial construction. It is needed,
because type @{typ "nat ⇒⇩0 nat"} does not satisfy the usual conditions of a "Dickson domain" (as
formulated in class @{class dickson_powerprod}), but we still want to use that type as the type of
power-products in the computation of Gr\"obner bases. So, we exploit the fact that in a finite
set of polynomials (which is the input of Buchberger's algorithm) there is always some "highest"
indeterminate that occurs with non-zero exponent, and no "higher" indeterminates are generated
during the execution of the algorithm. This allows us to prove that the algorithm terminates, even
though there are in principle infinitely many indeterminates.›
subsection ‹Additive Linear Orderings›
lemma group_eq_aux: "a + (b - a) = (b::'a::ab_group_add)"
proof -
have "a + (b - a) = b - a + a" by simp
also have "... = b" by simp
finally show ?thesis .
qed
class semi_canonically_ordered_monoid_add = ordered_comm_monoid_add +
assumes le_imp_add: "a ≤ b ⟹ (∃c. b = a + c)"
context canonically_ordered_monoid_add
begin
subclass semi_canonically_ordered_monoid_add
by (standard, simp only: le_iff_add)
end
class add_linorder_group = ordered_ab_semigroup_add_imp_le + ab_group_add + linorder
class add_linorder = ordered_ab_semigroup_add_imp_le + cancel_comm_monoid_add + semi_canonically_ordered_monoid_add + linorder
begin
subclass ordered_comm_monoid_add ..
subclass ordered_cancel_comm_monoid_add ..
lemma le_imp_inv:
assumes "a ≤ b"
shows "b = a + (b - a)"
using le_imp_add[OF assms] by auto
lemma max_eq_sum:
obtains y where "max a b = a + y"
unfolding max_def
proof (cases "a ≤ b")
case True
hence "b = a + (b - a)" by (rule le_imp_inv)
then obtain c where eq: "b = a + c" ..
show ?thesis
proof
from True show "max a b = a + c" unfolding max_def eq by simp
qed
next
case False
show ?thesis
proof
from False show "max a b = a + 0" unfolding max_def by simp
qed
qed
lemma min_plus_max:
shows "(min a b) + (max a b) = a + b"
proof (cases "a ≤ b")
case True
thus ?thesis unfolding min_def max_def by simp
next
case False
thus ?thesis unfolding min_def max_def by (simp add: ac_simps)
qed
end
class add_linorder_min = add_linorder +
assumes zero_min: "0 ≤ x"
begin
subclass ninv_comm_monoid_add
proof
fix x y
assume *: "x + y = 0"
show "x = 0"
proof -
from zero_min[of x] have "0 = x ∨ x > 0" by auto
thus ?thesis
proof
assume "x > 0"
have "0 ≤ y" by (fact zero_min)
also have "... = 0 + y" by simp
also from ‹x > 0› have "... < x + y" by (rule add_strict_right_mono)
finally have "0 < x + y" .
hence "x + y ≠ 0" by simp
from this * show ?thesis ..
qed simp
qed
qed
lemma leq_add_right:
shows "x ≤ x + y"
using add_left_mono[OF zero_min[of y], of x] by simp
lemma leq_add_left:
shows "x ≤ y + x"
using add_right_mono[OF zero_min[of y], of x] by simp
subclass canonically_ordered_monoid_add
by (standard, rule, elim le_imp_add, elim exE, simp add: leq_add_right)
end
class add_wellorder = add_linorder_min + wellorder
instantiation nat :: add_linorder
begin
instance by (standard, simp)
end
instantiation nat :: add_linorder_min
begin
instance by (standard, simp)
end
instantiation nat :: add_wellorder
begin
instance ..
end
context add_linorder_group
begin
subclass add_linorder
proof (standard, intro exI)
fix a b
show "b = a + (b - a)" using add_commute local.diff_add_cancel by auto
qed
end
instantiation int :: add_linorder_group
begin
instance ..
end
instantiation rat :: add_linorder_group
begin
instance ..
end
instantiation real :: add_linorder_group
begin
instance ..
end
subsection ‹Ordered Power-Products›
locale ordered_powerprod =
ordered_powerprod_lin: linorder ord ord_strict
for ord::"'a ⇒ 'a::comm_powerprod ⇒ bool" (infixl "≼" 50)
and ord_strict::"'a ⇒ 'a::comm_powerprod ⇒ bool" (infixl "≺" 50) +
assumes zero_min: "0 ≼ t"
assumes plus_monotone: "s ≼ t ⟹ s + u ≼ t + u"
begin
abbreviation ord_conv (infixl "≽" 50) where "ord_conv ≡ (≼)¯¯"
abbreviation ord_strict_conv (infixl "≻" 50) where "ord_strict_conv ≡ (≺)¯¯"
lemma ord_canc:
assumes "s + u ≼ t + u"
shows "s ≼ t"
proof (rule ordered_powerprod_lin.le_cases[of s t], simp)
assume "t ≼ s"
from assms plus_monotone[OF this, of u] have "t + u = s + u"
using ordered_powerprod_lin.eq_iff by simp
hence "t = s" by simp
thus "s ≼ t" by simp
qed
lemma ord_adds:
assumes "s adds t"
shows "s ≼ t"
proof -
from assms have "∃u. t = s + u" unfolding adds_def by simp
then obtain k where "t = s + k" ..
thus ?thesis using plus_monotone[OF zero_min[of k], of s] by (simp add: ac_simps)
qed
lemma ord_canc_left:
assumes "u + s ≼ u + t"
shows "s ≼ t"
using assms unfolding add.commute[of u] by (rule ord_canc)
lemma ord_strict_canc:
assumes "s + u ≺ t + u"
shows "s ≺ t"
using assms ord_canc[of s u t] add_right_cancel[of s u t]
ordered_powerprod_lin.le_imp_less_or_eq ordered_powerprod_lin.order.strict_implies_order by blast
lemma ord_strict_canc_left:
assumes "u + s ≺ u + t"
shows "s ≺ t"
using assms unfolding add.commute[of u] by (rule ord_strict_canc)
lemma plus_monotone_left:
assumes "s ≼ t"
shows "u + s ≼ u + t"
using assms
by (simp add: add.commute, rule plus_monotone)
lemma plus_monotone_strict:
assumes "s ≺ t"
shows "s + u ≺ t + u"
using assms
by (simp add: ordered_powerprod_lin.order.strict_iff_order plus_monotone)
lemma plus_monotone_strict_left:
assumes "s ≺ t"
shows "u + s ≺ u + t"
using assms
by (simp add: ordered_powerprod_lin.order.strict_iff_order plus_monotone_left)
end
locale gd_powerprod =
ordered_powerprod ord ord_strict
for ord::"'a ⇒ 'a::graded_dickson_powerprod ⇒ bool" (infixl "≼" 50)
and ord_strict (infixl "≺" 50)
begin
definition dickson_le :: "('a ⇒ nat) ⇒ nat ⇒ 'a ⇒ 'a ⇒ bool"
where "dickson_le d m s t ⟷ (d s ≤ m ∧ d t ≤ m ∧ s ≼ t)"
definition dickson_less :: "('a ⇒ nat) ⇒ nat ⇒ 'a ⇒ 'a ⇒ bool"
where "dickson_less d m s t ⟷ (d s ≤ m ∧ d t ≤ m ∧ s ≺ t)"
lemma dickson_leI:
assumes "d s ≤ m" and "d t ≤ m" and "s ≼ t"
shows "dickson_le d m s t"
using assms by (simp add: dickson_le_def)
lemma dickson_leD1:
assumes "dickson_le d m s t"
shows "d s ≤ m"
using assms by (simp add: dickson_le_def)
lemma dickson_leD2:
assumes "dickson_le d m s t"
shows "d t ≤ m"
using assms by (simp add: dickson_le_def)
lemma dickson_leD3:
assumes "dickson_le d m s t"
shows "s ≼ t"
using assms by (simp add: dickson_le_def)
lemma dickson_le_trans:
assumes "dickson_le d m s t" and "dickson_le d m t u"
shows "dickson_le d m s u"
using assms by (auto simp add: dickson_le_def)
lemma dickson_lessI:
assumes "d s ≤ m" and "d t ≤ m" and "s ≺ t"
shows "dickson_less d m s t"
using assms by (simp add: dickson_less_def)
lemma dickson_lessD1:
assumes "dickson_less d m s t"
shows "d s ≤ m"
using assms by (simp add: dickson_less_def)
lemma dickson_lessD2:
assumes "dickson_less d m s t"
shows "d t ≤ m"
using assms by (simp add: dickson_less_def)
lemma dickson_lessD3:
assumes "dickson_less d m s t"
shows "s ≺ t"
using assms by (simp add: dickson_less_def)
lemma dickson_less_irrefl: "¬ dickson_less d m t t"
by (simp add: dickson_less_def)
lemma dickson_less_trans:
assumes "dickson_less d m s t" and "dickson_less d m t u"
shows "dickson_less d m s u"
using assms by (auto simp add: dickson_less_def)
lemma transp_dickson_less: "transp (dickson_less d m)"
by (rule transpI, fact dickson_less_trans)
lemma wfp_on_ord_strict:
assumes "dickson_grading d"
shows "wfp_on (≺) {x. d x ≤ n}"
proof -
let ?A = "{x. d x ≤ n}"
have "strict (≼) = (≺)" by (intro ext, simp only: ordered_powerprod_lin.less_le_not_le)
have "qo_on (adds) ?A" by (auto simp: qo_on_def reflp_on_def transp_on_def dest: adds_trans)
moreover from assms have "wqo_on (adds) ?A" by (rule dickson_gradingD2')
ultimately have "(∀Q. (∀x∈?A. ∀y∈?A. x adds y ⟶ Q x y) ∧ qo_on Q ?A ⟶ wfp_on (strict Q) ?A)"
by (simp only: wqo_extensions_wf_conv)
hence "(∀x∈?A. ∀y∈?A. x adds y ⟶ x ≼ y) ∧ qo_on (≼) ?A ⟶ wfp_on (strict (≼)) ?A" ..
thus ?thesis unfolding ‹strict (≼) = (≺)›
proof
show "(∀x∈?A. ∀y∈?A. x adds y ⟶ x ≼ y) ∧ qo_on (≼) ?A"
proof (intro conjI ballI impI ord_adds)
show "qo_on (≼) ?A" by (auto simp: qo_on_def reflp_on_def transp_on_def)
qed
qed
qed
lemma wf_dickson_less:
assumes "dickson_grading d"
shows "wfP (dickson_less d m)"
proof (rule wfP_chain)
show "¬ (∃seq. ∀i. dickson_less d m (seq (Suc i)) (seq i))"
proof
assume "∃seq. ∀i. dickson_less d m (seq (Suc i)) (seq i)"
then obtain seq::"nat ⇒ 'a" where "∀i. dickson_less d m (seq (Suc i)) (seq i)" ..
hence *: "⋀i. dickson_less d m (seq (Suc i)) (seq i)" ..
with transp_dickson_less have seq_decr: "⋀i j. i < j ⟹ dickson_less d m (seq j) (seq i)"
by (rule transp_sequence)
from assms obtain i j where "i < j" and i_adds_j: "seq i adds seq j"
proof (rule dickson_gradingE)
fix i
from * show "d (seq i) ≤ m" by (rule dickson_lessD2)
qed
from ‹i < j› have "dickson_less d m (seq j) (seq i)" by (rule seq_decr)
hence "seq j ≺ seq i" by (rule dickson_lessD3)
moreover from i_adds_j have "seq i ≼ seq j" by (rule ord_adds)
ultimately show False by simp
qed
qed
end
text ‹‹gd_powerprod› stands for @{emph ‹graded ordered Dickson power-products›}.›
locale od_powerprod =
ordered_powerprod ord ord_strict
for ord::"'a ⇒ 'a::dickson_powerprod ⇒ bool" (infixl "≼" 50)
and ord_strict (infixl "≺" 50)
begin
sublocale gd_powerprod by standard
lemma wf_ord_strict: "wfP (≺)"
proof (rule wfP_chain)
show "¬ (∃seq. ∀i. seq (Suc i) ≺ seq i)"
proof
assume "∃seq. ∀i. seq (Suc i) ≺ seq i"
then obtain seq::"nat ⇒ 'a" where "∀i. seq (Suc i) ≺ seq i" ..
hence "⋀i. seq (Suc i) ≺ seq i" ..
with ordered_powerprod_lin.transp_less have seq_decr: "⋀i j. i < j ⟹ (seq j) ≺ (seq i)"
by (rule transp_sequence)
from dickson obtain i j::nat where "i < j" and i_adds_j: "seq i adds seq j"
by (auto elim!: almost_full_onD)
from seq_decr[OF ‹i < j›] have "seq j ≼ seq i ∧ seq j ≠ seq i" by auto
hence "seq j ≼ seq i" and "seq j ≠ seq i" by simp_all
from ‹seq j ≠ seq i› ‹seq j ≼ seq i› ord_adds[OF i_adds_j]
ordered_powerprod_lin.eq_iff[of "seq j" "seq i"]
show False by simp
qed
qed
end
text ‹‹od_powerprod› stands for @{emph ‹ordered Dickson power-products›}.›
subsection ‹Functions as Power-Products›
lemma finite_neq_0:
assumes fin_A: "finite {x. f x ≠ 0}" and fin_B: "finite {x. g x ≠ 0}" and "⋀x. h x 0 0 = 0"
shows "finite {x. h x (f x) (g x) ≠ 0}"
proof -
from fin_A fin_B have "finite ({x. f x ≠ 0} ∪ {x. g x ≠ 0})" by (intro finite_UnI)
hence finite_union: "finite {x. (f x ≠ 0) ∨ (g x ≠ 0)}" by (simp only: Collect_disj_eq)
have "{x. h x (f x) (g x) ≠ 0} ⊆ {x. (f x ≠ 0) ∨ (g x ≠ 0)}"
proof (intro Collect_mono, rule)
fix x::'a
assume h_not_zero: "h x (f x) (g x) ≠ 0"
have "f x = 0 ⟹ g x ≠ 0"
proof
assume "f x = 0" "g x = 0"
thus False using h_not_zero ‹h x 0 0 = 0› by simp
qed
thus "f x ≠ 0 ∨ g x ≠ 0" by auto
qed
from finite_subset[OF this] finite_union show "finite {x. h x (f x) (g x) ≠ 0}" .
qed
lemma finite_neq_0':
assumes "finite {x. f x ≠ 0}" and "finite {x. g x ≠ 0}" and "h 0 0 = 0"
shows "finite {x. h (f x) (g x) ≠ 0}"
using assms by (rule finite_neq_0)
lemma finite_neq_0_inv:
assumes fin_A: "finite {x. h x (f x) (g x) ≠ 0}" and fin_B: "finite {x. f x ≠ 0}" and "⋀x y. h x 0 y = y"
shows "finite {x. g x ≠ 0}"
proof -
from fin_A and fin_B have "finite ({x. h x (f x) (g x) ≠ 0} ∪ {x. f x ≠ 0})" by (intro finite_UnI)
hence finite_union: "finite {x. (h x (f x) (g x) ≠ 0) ∨ f x ≠ 0}" by (simp only: Collect_disj_eq)
have "{x. g x ≠ 0} ⊆ {x. (h x (f x) (g x) ≠ 0) ∨ f x ≠ 0}"
by (intro Collect_mono, rule, rule disjCI, simp add: assms(3))
from this finite_union show "finite {x. g x ≠ 0}" by (rule finite_subset)
qed
lemma finite_neq_0_inv':
assumes inf_A: "finite {x. h (f x) (g x) ≠ 0}" and fin_B: "finite {x. f x ≠ 0}" and "⋀x. h 0 x = x"
shows "finite {x. g x ≠ 0}"
using assms by (rule finite_neq_0_inv)
subsubsection ‹@{typ "'a ⇒ 'b"} belongs to class @{class comm_powerprod}›
instance "fun" :: (type, cancel_comm_monoid_add) comm_powerprod
by standard
subsubsection ‹@{typ "'a ⇒ 'b"} belongs to class @{class ninv_comm_monoid_add}›
instance "fun" :: (type, ninv_comm_monoid_add) ninv_comm_monoid_add
by (standard, simp only: plus_fun_def zero_fun_def fun_eq_iff, intro allI, rule plus_eq_zero, auto)
subsubsection ‹@{typ "'a ⇒ 'b"} belongs to class @{class lcs_powerprod}›
instantiation "fun" :: (type, add_linorder) lcs_powerprod
begin
definition lcs_fun::"('a ⇒ 'b) ⇒ ('a ⇒ 'b) ⇒ ('a ⇒ 'b)" where "lcs f g = (λx. max (f x) (g x))"
lemma adds_funI:
assumes "s ≤ t"
shows "s adds (t::'a ⇒ 'b)"
proof (rule addsI, rule)
fix x
from assms have "s x ≤ t x" unfolding le_fun_def ..
hence "t x = s x + (t x - s x)" by (rule le_imp_inv)
thus "t x = (s + (t - s)) x" by simp
qed
lemma adds_fun_iff: "f adds (g::'a ⇒ 'b) ⟷ (∀x. f x adds g x)"
unfolding adds_def plus_fun_def by metis
lemma adds_fun_iff': "f adds (g::'a ⇒ 'b) ⟷ (∀x. ∃y. g x = f x + y)"
unfolding adds_fun_iff unfolding adds_def plus_fun_def ..
lemma adds_lcs_fun:
shows "s adds (lcs s (t::'a ⇒ 'b))"
by (rule adds_funI, simp only: le_fun_def lcs_fun_def, auto simp: max_def)
lemma lcs_comm_fun: "lcs s t = lcs t (s::'a ⇒ 'b)"
unfolding lcs_fun_def
by (auto simp: max_def intro!: ext)
lemma lcs_adds_fun:
assumes "s adds u" and "t adds (u::'a ⇒ 'b)"
shows "(lcs s t) adds u"
using assms unfolding lcs_fun_def adds_fun_iff'
proof -
assume a1: "∀x. ∃y. u x = s x + y" and a2: "∀x. ∃y. u x = t x + y"
show "∀x. ∃y. u x = max (s x) (t x) + y"
proof
fix x
from a1 have b1: "∃y. u x = s x + y" ..
from a2 have b2: "∃y. u x = t x + y" ..
show "∃y. u x = max (s x) (t x) + y" unfolding max_def
by (split if_split, intro conjI impI, rule b2, rule b1)
qed
qed
instance
apply standard
subgoal by (rule adds_lcs_fun)
subgoal by (rule lcs_adds_fun)
subgoal by (rule lcs_comm_fun)
done
end
lemma leq_lcs_fun_1: "s ≤ (lcs s (t::'a ⇒ 'b::add_linorder))"
by (simp add: lcs_fun_def le_fun_def)
lemma leq_lcs_fun_2: "t ≤ (lcs s (t::'a ⇒ 'b::add_linorder))"
by (simp add: lcs_fun_def le_fun_def)
lemma lcs_leq_fun:
assumes "s ≤ u" and "t ≤ (u::'a ⇒ 'b::add_linorder)"
shows "(lcs s t) ≤ u"
using assms by (simp add: lcs_fun_def le_fun_def)
lemma adds_fun: "s adds t ⟷ s ≤ t"
for s t::"'a ⇒ 'b::add_linorder_min"
proof
assume "s adds t"
from this obtain k where "t = s + k" ..
show "s ≤ t" unfolding ‹t = s + k› le_fun_def plus_fun_def le_iff_add by (simp add: leq_add_right)
qed (rule adds_funI)
lemma gcs_fun: "gcs s (t::'a ⇒ ('b::add_linorder)) = (λx. min (s x) (t x))"
proof -
show ?thesis unfolding gcs_def lcs_fun_def fun_diff_def
proof (simp, rule)
fix x
have eq: "s x + t x = max (s x) (t x) + min (s x) (t x)" by (metis add.commute min_def max_def)
thus "s x + t x - max (s x) (t x) = min (s x) (t x)" by simp
qed
qed
lemma gcs_leq_fun_1: "(gcs s (t::'a ⇒ 'b::add_linorder)) ≤ s"
by (simp add: gcs_fun le_fun_def)
lemma gcs_leq_fun_2: "(gcs s (t::'a ⇒ 'b::add_linorder)) ≤ t"
by (simp add: gcs_fun le_fun_def)
lemma leq_gcs_fun:
assumes "u ≤ s" and "u ≤ (t::'a ⇒ 'b::add_linorder)"
shows "u ≤ (gcs s t)"
using assms by (simp add: gcs_fun le_fun_def)
subsubsection ‹@{typ "'a ⇒ 'b"} belongs to class @{class ulcs_powerprod}›
instance "fun" :: (type, add_linorder_min) ulcs_powerprod ..
subsubsection ‹Power-products in a given set of indeterminates›
definition supp_fun::"('a ⇒ 'b::zero) ⇒ 'a set" where "supp_fun f = {x. f x ≠ 0}"
text ‹@{term supp_fun} for general functions is like @{term keys} for @{type poly_mapping},
but does not need to be finite.›
lemma keys_eq_supp: "keys s = supp_fun (lookup s)"
unfolding supp_fun_def by (transfer, rule)
lemma supp_fun_zero [simp]: "supp_fun 0 = {}"
by (auto simp: supp_fun_def)
lemma supp_fun_eq_zero_iff: "supp_fun f = {} ⟷ f = 0"
by (auto simp: supp_fun_def)
lemma sub_supp_empty: "supp_fun s ⊆ {} ⟷ (s = 0)"
by (auto simp: supp_fun_def)
lemma except_fun_idI: "supp_fun f ∩ V = {} ⟹ except_fun f V = f"
by (auto simp: except_fun_def supp_fun_def when_def intro!: ext)
lemma supp_except_fun: "supp_fun (except_fun s V) = supp_fun s - V"
by (auto simp: except_fun_def supp_fun_def)
lemma supp_fun_plus_subset: "supp_fun (s + t) ⊆ supp_fun s ∪ supp_fun (t::'a ⇒ 'b::monoid_add)"
unfolding supp_fun_def by force
lemma fun_eq_zeroI:
assumes "⋀x. x ∈ supp_fun f ⟹ f x = 0"
shows "f = 0"
proof (rule, simp)
fix x
show "f x = 0"
proof (cases "x ∈ supp_fun f")
case True
then show ?thesis by (rule assms)
next
case False
then show ?thesis by (simp add: supp_fun_def)
qed
qed
lemma except_fun_cong1:
"supp_fun s ∩ ((V - U) ∪ (U - V)) ⊆ {} ⟹ except_fun s V = except_fun s U"
by (auto simp: except_fun_def when_def supp_fun_def intro!: ext)
lemma adds_except_fun:
"s adds t = (except_fun s V adds except_fun t V ∧ except_fun s (- V) adds except_fun t (- V))"
for s t :: "'a ⇒ 'b::add_linorder"
by (auto simp: supp_fun_def except_fun_def adds_fun_iff when_def)
lemma adds_except_fun_singleton: "s adds t = (except_fun s {v} adds except_fun t {v} ∧ s v adds t v)"
for s t :: "'a ⇒ 'b::add_linorder"
by (auto simp: supp_fun_def except_fun_def adds_fun_iff when_def)
subsubsection ‹Dickson's lemma for power-products in finitely many indeterminates›
lemma Dickson_fun:
assumes "finite V"
shows "almost_full_on (adds) {x::'a ⇒ 'b::add_wellorder. supp_fun x ⊆ V}"
using assms
proof (induct V)
case empty
have "finite {0}" by simp
moreover have "reflp_on (adds) {0::'a ⇒ 'b}" by (simp add: reflp_on_def)
ultimately have "almost_full_on (adds) {0::'a ⇒ 'b}" by (rule finite_almost_full_on)
thus ?case by (simp add: supp_fun_eq_zero_iff)
next
case (insert v V)
show ?case
proof (rule almost_full_onI)
fix seq::"nat ⇒ 'a ⇒ 'b"
assume "∀i. seq i ∈ {x. supp_fun x ⊆ insert v V}"
hence a: "supp_fun (seq i) ⊆ insert v V" for i by simp
define seq' where "seq' = (λi. (except_fun (seq i) {v}, except_fun (seq i) V))"
have "almost_full_on (adds) {x::'a ⇒ 'b. supp_fun x ⊆ {v}}"
proof (rule almost_full_onI)
fix f::"nat ⇒ 'a ⇒ 'b"
assume "∀i. f i ∈ {x. supp_fun x ⊆ {v}}"
hence b: "supp_fun (f i) ⊆ {v}" for i by simp
let ?f = "λi. f i v"
have "wfP ((<)::'b ⇒ _)" by (simp add: wf wfP_def)
hence "∀f::nat ⇒ 'b. ∃i. f i ≤ f (Suc i)"
by (simp add: wf_iff_no_infinite_down_chain[to_pred] not_less)
hence "∃i. ?f i ≤ ?f (Suc i)" ..
then obtain i where "?f i ≤ ?f (Suc i)" ..
have "i < Suc i" by simp
moreover have "f i adds f (Suc i)" unfolding adds_fun_iff
proof
fix x
show "f i x adds f (Suc i) x"
proof (cases "x = v")
case True
with ‹?f i ≤ ?f (Suc i)› show ?thesis by (simp add: adds_def le_iff_add)
next
case False
with b have "x ∉ supp_fun (f i)" and "x ∉ supp_fun (f (Suc i))" by blast+
thus ?thesis by (simp add: supp_fun_def)
qed
qed
ultimately show "good (adds) f" by (meson goodI)
qed
with insert(3) have
"almost_full_on (prod_le (adds) (adds)) ({x::'a ⇒ 'b. supp_fun x ⊆ V} × {x::'a ⇒ 'b. supp_fun x ⊆ {v}})"
(is "almost_full_on ?P ?A") by (rule almost_full_on_Sigma)
moreover from a have "seq' i ∈ ?A" for i by (auto simp add: seq'_def supp_except_fun)
ultimately obtain i j where "i < j" and "?P (seq' i) (seq' j)" by (rule almost_full_onD)
have "seq i adds seq j" unfolding adds_except_fun[where s="seq i" and V=V]
proof
from ‹?P (seq' i) (seq' j)› show "except_fun (seq i) V adds except_fun (seq j) V"
by (simp add: prod_le_def seq'_def)
next
from ‹?P (seq' i) (seq' j)› have "except_fun (seq i) {v} adds except_fun (seq j) {v}"
by (simp add: prod_le_def seq'_def)
moreover have "except_fun (seq i) (- V) = except_fun (seq i) {v}"
by (rule except_fun_cong1; use a[of i] insert.hyps(2) in blast)
moreover have "except_fun (seq j) (- V) = except_fun (seq j) {v}"
by (rule except_fun_cong1; use a[of j] insert.hyps(2) in blast)
ultimately show "except_fun (seq i) (- V) adds except_fun (seq j) (- V)" by simp
qed
with ‹i < j› show "good (adds) seq" by (meson goodI)
qed
qed
instance "fun" :: (finite, add_wellorder) dickson_powerprod
proof
have "finite (UNIV::'a set)" by simp
hence "almost_full_on (adds) {x::'a ⇒ 'b. supp_fun x ⊆ UNIV}" by (rule Dickson_fun)
thus "almost_full_on (adds) (UNIV::('a ⇒ 'b) set)" by simp
qed
subsubsection ‹Lexicographic Term Order›
text ‹Term orders are certain linear orders on power-products, satisfying additional requirements.
Further information on term orders can be found, e.\,g., in @{cite Robbiano1985}.›
context wellorder
begin
lemma neq_fun_alt:
assumes "s ≠ (t::'a ⇒ 'b)"
obtains x where "s x ≠ t x" and "⋀y. s y ≠ t y ⟹ x ≤ y"
proof -
from assms ext[of s t] have "∃x. s x ≠ t x" by auto
with exists_least_iff[of "λx. s x ≠ t x"]
obtain x where x1: "s x ≠ t x" and x2: "⋀y. y < x ⟹ s y = t y"
by auto
show ?thesis
proof
from x1 show "s x ≠ t x" .
next
fix y
assume "s y ≠ t y"
with x2[of y] have "¬ y < x" by auto
thus "x ≤ y" by simp
qed
qed
definition lex_fun::"('a ⇒ 'b) ⇒ ('a ⇒ 'b::order) ⇒ bool" where
"lex_fun s t ≡ (∀x. s x ≤ t x ∨ (∃y<x. s y ≠ t y))"
definition "lex_fun_strict s t ⟷ lex_fun s t ∧ ¬ lex_fun t s"
text ‹Attention! @{term lex_fun} reverses the order of the indeterminates: if @{term x} is smaller than
@{term y} w.r.t. the order on @{typ 'a}, then the @{emph ‹power-product›} @{term x} is
@{emph ‹greater›} than the @{emph ‹power-product›} @{term y}.›
lemma lex_fun_alt:
shows "lex_fun s t = (s = t ∨ (∃x. s x < t x ∧ (∀y<x. s y = t y)))" (is "?L = ?R")
proof
assume ?L
show ?R
proof (cases "s = t")
assume "s = t"
thus ?R by simp
next
assume "s ≠ t"
from neq_fun_alt[OF this] obtain x0
where x0_neq: "s x0 ≠ t x0" and x0_min: "⋀z. s z ≠ t z ⟹ x0 ≤ z" by auto
show ?R
proof (intro disjI2, rule exI[of _ x0], intro conjI)
from ‹?L› have "s x0 ≤ t x0 ∨ (∃y. y < x0 ∧ s y ≠ t y)" unfolding lex_fun_def ..
thus "s x0 < t x0"
proof
assume "s x0 ≤ t x0"
from this x0_neq show ?thesis by simp
next
assume "∃y. y < x0 ∧ s y ≠ t y"
then obtain y where "y < x0" and y_neq: "s y ≠ t y" by auto
from ‹y < x0› x0_min[OF y_neq] show ?thesis by simp
qed
next
show "∀y<x0. s y = t y"
proof (rule, rule)
fix y
assume "y < x0"
hence "¬ x0 ≤ y" by simp
from this x0_min[of y] show "s y = t y" by auto
qed
qed
qed
next
assume ?R
thus ?L
proof
assume "s = t"
thus ?thesis by (simp add: lex_fun_def)
next
assume "∃x. s x < t x ∧ (∀y<x. s y = t y)"
then obtain y where y: "s y < t y" and y_min: "∀z<y. s z = t z" by auto
show ?thesis unfolding lex_fun_def
proof
fix x
show "s x ≤ t x ∨ (∃y<x. s y ≠ t y)"
proof (cases "s x ≤ t x")
assume "s x ≤ t x"
thus ?thesis by simp
next
assume x: "¬ s x ≤ t x"
show ?thesis
proof (intro disjI2, rule exI[of _ y], intro conjI)
have "¬ x ≤ y"
proof
assume "x ≤ y"
hence "x < y ∨ y = x" by auto
thus False
proof
assume "x < y"
from x y_min[rule_format, OF this] show ?thesis by simp
next
assume "y = x"
from this x y show ?thesis
by (auto simp: preorder_class.less_le_not_le)
qed
qed
thus "y < x" by simp
next
from y show "s y ≠ t y" by simp
qed
qed
qed
qed
qed
lemma lex_fun_refl: "lex_fun s s"
unfolding lex_fun_alt by simp
lemma lex_fun_antisym:
assumes "lex_fun s t" and "lex_fun t s"
shows "s = t"
proof
fix x
from assms(1) have "s = t ∨ (∃x. s x < t x ∧ (∀y<x. s y = t y))"
unfolding lex_fun_alt .
thus "s x = t x"
proof
assume "s = t"
thus ?thesis by simp
next
assume "∃x. s x < t x ∧ (∀y<x. s y = t y)"
then obtain x0 where x0: "s x0 < t x0" and x0_min: "∀y<x0. s y = t y" by auto
from assms(2) have "t = s ∨ (∃x. t x < s x ∧ (∀y<x. t y = s y))" unfolding lex_fun_alt .
thus ?thesis
proof
assume "t = s"
thus ?thesis by simp
next
assume "∃x. t x < s x ∧ (∀y<x. t y = s y)"
then obtain x1 where x1: "t x1 < s x1" and x1_min: "∀y<x1. t y = s y" by auto
have "x0 < x1 ∨ x1 < x0 ∨ x1 = x0" using local.antisym_conv3 by auto
show ?thesis
proof (rule linorder_cases[of x0 x1])
assume "x1 < x0"
from x0_min[rule_format, OF this] x1 show ?thesis by simp
next
assume "x0 = x1"
from this x0 x1 show ?thesis by simp
next
assume "x0 < x1"
from x1_min[rule_format, OF this] x0 show ?thesis by simp
qed
qed
qed
qed
lemma lex_fun_trans:
assumes "lex_fun s t" and "lex_fun t u"
shows "lex_fun s u"
proof -
from assms(1) have "s = t ∨ (∃x. s x < t x ∧ (∀y<x. s y = t y))" unfolding lex_fun_alt .
thus ?thesis
proof
assume "s = t"
from this assms(2) show ?thesis by simp
next
assume "∃x. s x < t x ∧ (∀y<x. s y = t y)"
then obtain x0 where x0: "s x0 < t x0" and x0_min: "∀y<x0. s y = t y"
by auto
from assms(2) have "t = u ∨ (∃x. t x < u x ∧ (∀y<x. t y = u y))" unfolding lex_fun_alt .
thus ?thesis
proof
assume "t = u"
from this assms(1) show ?thesis by simp
next
assume "∃x. t x < u x ∧ (∀y<x. t y = u y)"
then obtain x1 where x1: "t x1 < u x1" and x1_min: "∀y<x1. t y = u y" by auto
show ?thesis unfolding lex_fun_alt
proof (intro disjI2)
show "∃x. s x < u x ∧ (∀y<x. s y = u y)"
proof (rule linorder_cases[of x0 x1])
assume "x1 < x0"
show ?thesis
proof (rule exI[of _ x1], intro conjI)
from x0_min[rule_format, OF ‹x1 < x0›] x1 show "s x1 < u x1" by simp
next
show "∀y<x1. s y = u y"
proof (intro allI, intro impI)
fix y
assume "y < x1"
from this ‹x1 < x0› have "y < x0" by simp
from x0_min[rule_format, OF this] x1_min[rule_format, OF ‹y < x1›]
show "s y = u y" by simp
qed
qed
next
assume "x0 < x1"
show ?thesis
proof (rule exI[of _ x0], intro conjI)
from x1_min[rule_format, OF ‹x0 < x1›] x0 show "s x0 < u x0" by simp
next
show "∀y<x0. s y = u y"
proof (intro allI, intro impI)
fix y
assume "y < x0"
from this ‹x0 < x1› have "y < x1" by simp
from x0_min[rule_format, OF ‹y < x0›] x1_min[rule_format, OF this]
show "s y = u y" by simp
qed
qed
next
assume "x0 = x1"
show ?thesis
proof (rule exI[of _ x1], intro conjI)
from ‹x0 = x1› x0 x1 show "s x1 < u x1" by simp
next
show "∀y<x1. s y = u y"
proof (intro allI, intro impI)
fix y
assume "y < x1"
hence "y < x0" using ‹x0 = x1› by simp
from x0_min[rule_format, OF this] x1_min[rule_format, OF ‹y < x1›]
show "s y = u y" by simp
qed
qed
qed
qed
qed
qed
qed
lemma lex_fun_lin: "lex_fun s t ∨ lex_fun t s" for s t::"'a ⇒ 'b::{ordered_comm_monoid_add, linorder}"
proof (intro disjCI)
assume "¬ lex_fun t s"
hence a: "∀x. ¬ (t x < s x) ∨ (∃y<x. t y ≠ s y)" unfolding lex_fun_alt by auto
show "lex_fun s t" unfolding lex_fun_def
proof
fix x
from a have "¬ (t x < s x) ∨ (∃y<x. t y ≠ s y)" ..
thus "s x ≤ t x ∨ (∃y<x. s y ≠ t y)" by auto
qed
qed
corollary lex_fun_strict_alt [code]:
"lex_fun_strict s t = (¬ lex_fun t s)" for s t::"'a ⇒ 'b::{ordered_comm_monoid_add, linorder}"
unfolding lex_fun_strict_def using lex_fun_lin[of s t] by auto
lemma lex_fun_zero_min: "lex_fun 0 s" for s::"'a ⇒ 'b::add_linorder_min"
by (simp add: lex_fun_def zero_min)
lemma lex_fun_plus_monotone:
"lex_fun (s + u) (t + u)" if "lex_fun s t"
for s t::"'a ⇒ 'b::ordered_cancel_comm_monoid_add"
unfolding lex_fun_def
proof
fix x
from that have "s x ≤ t x ∨ (∃y<x. s y ≠ t y)" unfolding lex_fun_def ..
thus "(s + u) x ≤ (t + u) x ∨ (∃y<x. (s + u) y ≠ (t + u) y)"
proof
assume a1: "s x ≤ t x"
show ?thesis
proof (intro disjI1)
from a1 show "(s + u) x ≤ (t + u) x" by (auto simp: add_right_mono)
qed
next
assume "∃y<x. s y ≠ t y"
then obtain y where "y < x" and a2: "s y ≠ t y" by auto
show ?thesis
proof (intro disjI2, rule exI[of _ y], intro conjI, fact)
from a2 show "(s + u) y ≠ (t + u) y" by (auto simp: add_right_mono)
qed
qed
qed
end
subsubsection ‹Degree›
definition deg_fun::"('a ⇒ 'b::comm_monoid_add) ⇒ 'b" where "deg_fun s ≡ ∑x∈(supp_fun s). s x"
lemma deg_fun_zero[simp]: "deg_fun 0 = 0"
by (auto simp: deg_fun_def)
lemma deg_fun_eq_0_iff:
assumes "finite (supp_fun (s::'a ⇒ 'b::add_linorder_min))"
shows "deg_fun s = 0 ⟷ s = 0"
proof
assume "deg_fun s = 0"
hence *: "(∑x∈(supp_fun s). s x) = 0" by (simp only: deg_fun_def)
have **: "⋀x. 0 ≤ s x" by (rule zero_min)
from * have "⋀x. x ∈ supp_fun s ⟹ s x = 0" by (simp only: sum_nonneg_eq_0_iff[OF assms **])
thus "s = 0" by (rule fun_eq_zeroI)
qed simp
lemma deg_fun_superset:
fixes A::"'a set"
assumes "supp_fun s ⊆ A" and "finite A"
shows "deg_fun s = (∑x∈A. s x)"
unfolding deg_fun_def
proof (rule sum.mono_neutral_cong_left, fact, fact, rule)
fix x
assume "x ∈ A - supp_fun s"
hence "x ∉ supp_fun s" by simp
thus "s x = 0" by (simp add: supp_fun_def)
qed rule
lemma deg_fun_plus:
assumes "finite (supp_fun s)" and "finite (supp_fun t)"
shows "deg_fun (s + t) = deg_fun s + deg_fun (t::'a ⇒ 'b::comm_monoid_add)"
proof -
from assms have fin: "finite (supp_fun s ∪ supp_fun t)" by simp
have "deg_fun (s + t) = (∑x∈(supp_fun (s + t)). s x + t x)" by (simp add: deg_fun_def)
also from fin have "... = (∑x∈(supp_fun s ∪ supp_fun t). s x + t x)"
proof (rule sum.mono_neutral_cong_left)
show "∀x∈supp_fun s ∪ supp_fun t - supp_fun (s + t). s x + t x = 0"
proof
fix x
assume "x ∈ supp_fun s ∪ supp_fun t - supp_fun (s + t)"
hence "x ∉ supp_fun (s + t)" by simp
thus "s x + t x = 0" by (simp add: supp_fun_def)
qed
qed (rule supp_fun_plus_subset, rule)
also have "… = (∑x∈(supp_fun s ∪ supp_fun t). s x) + (∑x∈(supp_fun s ∪ supp_fun t). t x)"
by (rule sum.distrib)
also from fin have "(∑x∈(supp_fun s ∪ supp_fun t). s x) = deg_fun s" unfolding deg_fun_def
proof (rule sum.mono_neutral_cong_right)
show "∀x∈supp_fun s ∪ supp_fun t - supp_fun s. s x = 0"
proof
fix x
assume "x ∈ supp_fun s ∪ supp_fun t - supp_fun s"
hence "x ∉ supp_fun s" by simp
thus "s x = 0" by (simp add: supp_fun_def)
qed
qed simp_all
also from fin have "(∑x∈(supp_fun s ∪ supp_fun t). t x) = deg_fun t" unfolding deg_fun_def
proof (rule sum.mono_neutral_cong_right)
show "∀x∈supp_fun s ∪ supp_fun t - supp_fun t. t x = 0"
proof
fix x
assume "x ∈ supp_fun s ∪ supp_fun t - supp_fun t"
hence "x ∉ supp_fun t" by simp
thus "t x = 0" by (simp add: supp_fun_def)
qed
qed simp_all
finally show ?thesis .
qed
lemma deg_fun_leq:
assumes "finite (supp_fun s)" and "finite (supp_fun t)" and "s ≤ (t::'a ⇒ 'b::ordered_comm_monoid_add)"
shows "deg_fun s ≤ deg_fun t"
proof -
let ?A = "supp_fun s ∪ supp_fun t"
from assms(1) assms(2) have 1: "finite ?A" by simp
have s: "supp_fun s ⊆ ?A" and t: "supp_fun t ⊆ ?A" by simp_all
show ?thesis unfolding deg_fun_superset[OF s 1] deg_fun_superset[OF t 1]
proof (rule sum_mono)
fix i
from assms(3) show "s i ≤ t i" unfolding le_fun_def ..
qed
qed
subsubsection ‹General Degree-Orders›
context linorder
begin
lemma ex_min:
assumes "finite (A::'a set)" and "A ≠ {}"
shows "∃y∈A. (∀z∈A. y ≤ z)"
using assms
proof (induct rule: finite_induct)
assume "{} ≠ {}"
thus "∃y∈{}. ∀z∈{}. y ≤ z" by simp
next
fix a::'a and A::"'a set"
assume "a ∉ A" and IH: "A ≠ {} ⟹ ∃y∈A. (∀z∈A. y ≤ z)"
show "∃y∈insert a A. (∀z∈insert a A. y ≤ z)"
proof (cases "A = {}")
case True
show ?thesis
proof (rule bexI[of _ a], intro ballI)
fix z
assume "z ∈ insert a A"
from this True have "z = a" by simp
thus "a ≤ z" by simp
qed (simp)
next
case False
from IH[OF False] obtain y where "y ∈ A" and y_min: "∀z∈A. y ≤ z" by auto
from linear[of a y] show ?thesis
proof
assume "y ≤ a"
show ?thesis
proof (rule bexI[of _ y], intro ballI)
fix z
assume "z ∈ insert a A"
hence "z = a ∨ z ∈ A" by simp
thus "y ≤ z"
proof
assume "z = a"
from this ‹y ≤ a› show "y ≤ z" by simp
next
assume "z ∈ A"
from y_min[rule_format, OF this] show "y ≤ z" .
qed
next
from ‹y ∈ A› show "y ∈ insert a A" by simp
qed
next
assume "a ≤ y"
show ?thesis
proof (rule bexI[of _ a], intro ballI)
fix z
assume "z ∈ insert a A"
hence "z = a ∨ z ∈ A" by simp
thus "a ≤ z"
proof
assume "z = a"
from this show "a ≤ z" by simp
next
assume "z ∈ A"
from y_min[rule_format, OF this] ‹a ≤ y› show "a ≤ z" by simp
qed
qed (simp)
qed
qed
qed
definition dord_fun::"(('a ⇒ 'b::ordered_comm_monoid_add) ⇒ ('a ⇒ 'b) ⇒ bool) ⇒ ('a ⇒ 'b) ⇒ ('a ⇒ 'b) ⇒ bool"
where "dord_fun ord s t ≡ (let d1 = deg_fun s; d2 = deg_fun t in (d1 < d2 ∨ (d1 = d2 ∧ ord s t)))"
lemma dord_fun_degD:
assumes "dord_fun ord s t"
shows "deg_fun s ≤ deg_fun t"
using assms unfolding dord_fun_def Let_def by auto
lemma dord_fun_refl:
assumes "ord s s"
shows "dord_fun ord s s"
using assms unfolding dord_fun_def by simp
lemma dord_fun_antisym:
assumes ord_antisym: "ord s t ⟹ ord t s ⟹ s = t" and "dord_fun ord s t" and "dord_fun ord t s"
shows "s = t"
proof -
from assms(3) have ts: "deg_fun t < deg_fun s ∨ (deg_fun t = deg_fun s ∧ ord t s)"
unfolding dord_fun_def Let_def .
from assms(2) have st: "deg_fun s < deg_fun t ∨ (deg_fun s = deg_fun t ∧ ord s t)"
unfolding dord_fun_def Let_def .
thus ?thesis
proof
assume "deg_fun s < deg_fun t"
thus ?thesis using ts by auto
next
assume "deg_fun s = deg_fun t ∧ ord s t"
hence "deg_fun s = deg_fun t" and "ord s t" by simp_all
from ‹deg_fun s = deg_fun t› ts have "ord t s" by simp
with ‹ord s t› show ?thesis by (rule ord_antisym)
qed
qed
lemma dord_fun_trans:
assumes ord_trans: "ord s t ⟹ ord t u ⟹ ord s u" and "dord_fun ord s t" and "dord_fun ord t u"
shows "dord_fun ord s u"
proof -
from assms(3) have ts: "deg_fun t < deg_fun u ∨ (deg_fun t = deg_fun u ∧ ord t u)"
unfolding dord_fun_def Let_def .
from assms(2) have st: "deg_fun s < deg_fun t ∨ (deg_fun s = deg_fun t ∧ ord s t)"
unfolding dord_fun_def Let_def .
thus ?thesis
proof
assume "deg_fun s < deg_fun t"
from this dord_fun_degD[OF assms(3)] have "deg_fun s < deg_fun u" by simp
thus ?thesis by (simp add: dord_fun_def Let_def)
next
assume "deg_fun s = deg_fun t ∧ ord s t"
hence "deg_fun s = deg_fun t" and "ord s t" by simp_all
from ts show ?thesis
proof
assume "deg_fun t < deg_fun u"
hence "deg_fun s < deg_fun u" using ‹deg_fun s = deg_fun t› by simp
thus ?thesis by (simp add: dord_fun_def Let_def)
next
assume "deg_fun t = deg_fun u ∧ ord t u"
hence "deg_fun t = deg_fun u" and "ord t u" by simp_all
from ord_trans[OF ‹ord s t› ‹ord t u›] ‹deg_fun s = deg_fun t› ‹deg_fun t = deg_fun u› show ?thesis
by (simp add: dord_fun_def Let_def)
qed
qed
qed
lemma dord_fun_lin:
"dord_fun ord s t ∨ dord_fun ord t s"
if "ord s t ∨ ord t s"
for s t::"'a ⇒ 'b::{ordered_comm_monoid_add, linorder}"
proof (intro disjCI)
assume "¬ dord_fun ord t s"
hence "deg_fun s ≤ deg_fun t ∧ (deg_fun t ≠ deg_fun s ∨ ¬ ord t s)"
unfolding dord_fun_def Let_def by auto
hence "deg_fun s ≤ deg_fun t" and dis1: "deg_fun t ≠ deg_fun s ∨ ¬ ord t s" by simp_all
show "dord_fun ord s t" unfolding dord_fun_def Let_def
proof (intro disjCI)
assume "¬ (deg_fun s = deg_fun t ∧ ord s t)"
hence dis2: "deg_fun s ≠ deg_fun t ∨ ¬ ord s t" by simp
show "deg_fun s < deg_fun t"
proof (cases "deg_fun s = deg_fun t")
case True
from True dis1 have "¬ ord t s" by simp
from True dis2 have "¬ ord s t" by simp
from ‹¬ ord s t› ‹¬ ord t s› that show ?thesis by simp
next
case False
from this ‹deg_fun s ≤ deg_fun t› show ?thesis by simp
qed
qed
qed
lemma dord_fun_zero_min:
fixes s t::"'a ⇒ 'b::add_linorder_min"
assumes ord_refl: "⋀t. ord t t" and "finite (supp_fun s)"
shows "dord_fun ord 0 s"
unfolding dord_fun_def Let_def deg_fun_zero
proof (rule disjCI)
assume "¬ (0 = deg_fun s ∧ ord 0 s)"
hence dis: "deg_fun s ≠ 0 ∨ ¬ ord 0 s" by simp
show "0 < deg_fun s"
proof (cases "deg_fun s = 0")
case True
hence "s = 0" using deg_fun_eq_0_iff[OF assms(2)] by auto
hence "ord 0 s" using ord_refl by simp
with True dis show ?thesis by simp
next
case False
thus ?thesis by (auto simp: zero_less_iff_neq_zero)
qed
qed
lemma dord_fun_plus_monotone:
fixes s t u ::"'a ⇒ 'b::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
assumes ord_monotone: "ord s t ⟹ ord (s + u) (t + u)" and "finite (supp_fun s)"
and "finite (supp_fun t)" and "finite (supp_fun u)" and "dord_fun ord s t"
shows "dord_fun ord (s + u) (t + u)"
proof -
from assms(5) have "deg_fun s < deg_fun t ∨ (deg_fun s = deg_fun t ∧ ord s t)"
unfolding dord_fun_def Let_def .
thus ?thesis
proof
assume "deg_fun s < deg_fun t"
hence "deg_fun (s + u) < deg_fun (t + u)" by (auto simp: deg_fun_plus[OF _ assms(4)] assms(2) assms(3))
thus ?thesis unfolding dord_fun_def Let_def by simp
next
assume "deg_fun s = deg_fun t ∧ ord s t"
hence "deg_fun s = deg_fun t" and "ord s t" by simp_all
from ‹deg_fun s = deg_fun t› have "deg_fun (s + u) = deg_fun (t + u)"
by (auto simp: deg_fun_plus[OF _ assms(4)] assms(2) assms(3))
from this ord_monotone[OF ‹ord s t›] show ?thesis unfolding dord_fun_def Let_def by simp
qed
qed
end
context wellorder
begin
subsubsection ‹Degree-Lexicographic Term Order›
definition dlex_fun::"('a ⇒ 'b::ordered_comm_monoid_add) ⇒ ('a ⇒ 'b) ⇒ bool"
where "dlex_fun ≡ dord_fun lex_fun"
definition "dlex_fun_strict s t ⟷ dlex_fun s t ∧ ¬ dlex_fun t s"
lemma dlex_fun_refl:
shows "dlex_fun s s"
unfolding dlex_fun_def by (rule dord_fun_refl, rule lex_fun_refl)
lemma dlex_fun_antisym:
assumes "dlex_fun s t" and "dlex_fun t s"
shows "s = t"
by (rule dord_fun_antisym, erule lex_fun_antisym, assumption,
simp_all only: dlex_fun_def[symmetric], fact+)
lemma dlex_fun_trans:
assumes "dlex_fun s t" and "dlex_fun t u"
shows "dlex_fun s u"
by (simp only: dlex_fun_def, rule dord_fun_trans, erule lex_fun_trans, assumption,
simp_all only: dlex_fun_def[symmetric], fact+)
lemma dlex_fun_lin: "dlex_fun s t ∨ dlex_fun t s"
for s t::"('a ⇒ 'b::{ordered_comm_monoid_add, linorder})"
unfolding dlex_fun_def by (rule dord_fun_lin, rule lex_fun_lin)
corollary dlex_fun_strict_alt [code]:
"dlex_fun_strict s t = (¬ dlex_fun t s)" for s t::"'a ⇒ 'b::{ordered_comm_monoid_add, linorder}"
unfolding dlex_fun_strict_def using dlex_fun_lin by auto
lemma dlex_fun_zero_min:
fixes s t::"('a ⇒ 'b::add_linorder_min)"
assumes "finite (supp_fun s)"
shows "dlex_fun 0 s"
unfolding dlex_fun_def by (rule dord_fun_zero_min, rule lex_fun_refl, fact)
lemma dlex_fun_plus_monotone:
fixes s t u::"'a ⇒ 'b::{ordered_cancel_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
assumes "finite (supp_fun s)" and "finite (supp_fun t)" and "finite (supp_fun u)" and "dlex_fun s t"
shows "dlex_fun (s + u) (t + u)"
using lex_fun_plus_monotone[of s t u] assms unfolding dlex_fun_def
by (rule dord_fun_plus_monotone)
subsubsection ‹Degree-Reverse-Lexicographic Term Order›
abbreviation rlex_fun::"('a ⇒ 'b) ⇒ ('a ⇒ 'b::order) ⇒ bool" where
"rlex_fun s t ≡ lex_fun t s"
text ‹Note that @{const rlex_fun} is not precisely the reverse-lexicographic order relation on
power-products. Normally, the @{emph ‹last›} (i.\,e. highest) indeterminate whose exponent differs
in the two power-products to be compared is taken, but since we do not require the domain to be finite,
there might not be such a last indeterminate. Therefore, we simply take the converse of
@{const lex_fun}.›
definition drlex_fun::"('a ⇒ 'b::ordered_comm_monoid_add) ⇒ ('a ⇒ 'b) ⇒ bool"
where "drlex_fun ≡ dord_fun rlex_fun"
definition "drlex_fun_strict s t ⟷ drlex_fun s t ∧ ¬ drlex_fun t s"
lemma drlex_fun_refl:
shows "drlex_fun s s"
unfolding drlex_fun_def by (rule dord_fun_refl, fact lex_fun_refl)
lemma drlex_fun_antisym:
assumes "drlex_fun s t" and "drlex_fun t s"
shows "s = t"
by (rule dord_fun_antisym, erule lex_fun_antisym, assumption,
simp_all only: drlex_fun_def[symmetric], fact+)
lemma drlex_fun_trans:
assumes "drlex_fun s t" and "drlex_fun t u"
shows "drlex_fun s u"
by (simp only: drlex_fun_def, rule dord_fun_trans, erule lex_fun_trans, assumption,
simp_all only: drlex_fun_def[symmetric], fact+)
lemma drlex_fun_lin: "drlex_fun s t ∨ drlex_fun t s"
for s t::"('a ⇒ 'b::{ordered_comm_monoid_add, linorder})"
unfolding drlex_fun_def by (rule dord_fun_lin, rule lex_fun_lin)
corollary drlex_fun_strict_alt [code]:
"drlex_fun_strict s t = (¬ drlex_fun t s)" for s t::"'a ⇒ 'b::{ordered_comm_monoid_add, linorder}"
unfolding drlex_fun_strict_def using drlex_fun_lin by auto
lemma drlex_fun_zero_min:
fixes s t::"('a ⇒ 'b::add_linorder_min)"
assumes "finite (supp_fun s)"
shows "drlex_fun 0 s"
unfolding drlex_fun_def by (rule dord_fun_zero_min, rule lex_fun_refl, fact)
lemma drlex_fun_plus_monotone:
fixes s t u::"'a ⇒ 'b::{ordered_cancel_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
assumes "finite (supp_fun s)" and "finite (supp_fun t)" and "finite (supp_fun u)" and "drlex_fun s t"
shows "drlex_fun (s + u) (t + u)"
using lex_fun_plus_monotone[of t s u] assms unfolding drlex_fun_def
by (rule dord_fun_plus_monotone)
end
text‹Every finite linear ordering is also a well-ordering. This fact is particularly useful when
working with fixed finite sets of indeterminates.›
class finite_linorder = finite + linorder
begin
subclass wellorder
proof
fix P::"'a ⇒ bool" and a
assume hyp: "⋀x. (⋀y. (y < x) ⟹ P y) ⟹ P x"
show "P a"
proof (rule ccontr)
assume "¬ P a"
have "finite {x. ¬ P x}" (is "finite ?A") by simp
from ‹¬ P a› have "a ∈ ?A" by simp
hence "?A ≠ {}" by auto
from ex_min[OF ‹finite ?A› this] obtain b where "b ∈ ?A" and b_min: "∀y∈?A. b ≤ y" by auto
from ‹b ∈ ?A› have "¬ P b" by simp
with hyp[of b] obtain y where "y < b" and "¬ P y" by auto
from ‹¬ P y› have "y ∈ ?A" by simp
with b_min have "b ≤ y" by simp
with ‹y < b› show False by simp
qed
qed
end
subsection ‹Type @{type poly_mapping}›
lemma poly_mapping_eq_zeroI:
assumes "keys s = {}"
shows "s = (0::('a, 'b::zero) poly_mapping)"
proof (rule poly_mapping_eqI, simp)
fix x
from assms show "lookup s x = 0" by auto
qed
lemma keys_plus_ninv_comm_monoid_add: "keys (s + t) = keys s ∪ keys (t::'a ⇒⇩0 'b::ninv_comm_monoid_add)"
proof (rule, fact Poly_Mapping.keys_add, rule)
fix x
assume "x ∈ keys s ∪ keys t"
thus "x ∈ keys (s + t)"
proof
assume "x ∈ keys s"
thus ?thesis
by (metis in_keys_iff lookup_add plus_eq_zero)
next
assume "x ∈ keys t"
thus ?thesis
by (metis in_keys_iff lookup_add plus_eq_zero_2)
qed
qed
lemma lookup_zero_fun: "lookup 0 = 0"
by (simp only: zero_poly_mapping.rep_eq zero_fun_def)
lemma lookup_plus_fun: "lookup (s + t) = lookup s + lookup t"
by (simp only: plus_poly_mapping.rep_eq plus_fun_def)
lemma lookup_uminus_fun: "lookup (- s) = - lookup s"
by (fact uminus_poly_mapping.rep_eq)
lemma lookup_minus_fun: "lookup (s - t) = lookup s - lookup t"
by (simp only: minus_poly_mapping.rep_eq, rule, simp only: minus_apply)
lemma poly_mapping_adds_iff: "s adds t ⟷ lookup s adds lookup t"
unfolding adds_def
proof
assume "∃k. t = s + k"
then obtain k where *: "t = s + k" ..
show "∃k. lookup t = lookup s + k"
proof
from * show "lookup t = lookup s + lookup k" by (simp only: lookup_plus_fun)
qed
next
assume "∃k. lookup t = lookup s + k"
then obtain k where *: "lookup t = lookup s + k" ..
have **: "k ∈ {f. finite {x. f x ≠ 0}}"
proof
have "finite {x. lookup t x ≠ 0}" by transfer
hence "finite {x. lookup s x + k x ≠ 0}" by (simp only: * plus_fun_def)
moreover have "finite {x. lookup s x ≠ 0}" by transfer
ultimately show "finite {x. k x ≠ 0}" by (rule finite_neq_0_inv', simp)
qed
show "∃k. t = s + k"
proof
show "t = s + Abs_poly_mapping k"
by (rule poly_mapping_eqI, simp add: * lookup_add Abs_poly_mapping_inverse[OF **])
qed
qed
subsubsection ‹@{typ "('a, 'b) poly_mapping"} belongs to class @{class comm_powerprod}›
instance poly_mapping :: (type, cancel_comm_monoid_add) comm_powerprod
by standard
subsubsection ‹@{typ "('a, 'b) poly_mapping"} belongs to class @{class ninv_comm_monoid_add}›
instance poly_mapping :: (type, ninv_comm_monoid_add) ninv_comm_monoid_add
proof (standard, transfer)
fix s t::"'a ⇒ 'b"
assume "(λk. s k + t k) = (λ_. 0)"
hence "s + t = 0" by (simp only: plus_fun_def zero_fun_def)
hence "s = 0" by (rule plus_eq_zero)
thus "s = (λ_. 0)" by (simp only: zero_fun_def)
qed
subsubsection ‹@{typ "('a, 'b) poly_mapping"} belongs to class @{class lcs_powerprod}›
instantiation poly_mapping :: (type, add_linorder) lcs_powerprod
begin
lift_definition lcs_poly_mapping::"('a ⇒⇩0 'b) ⇒ ('a ⇒⇩0 'b) ⇒ ('a ⇒⇩0 'b)" is "λs t. λx. max (s x) (t x)"
proof -
fix fun1 fun2::"'a ⇒ 'b"
assume "finite {t. fun1 t ≠ 0}" and "finite {t. fun2 t ≠ 0}"
from finite_neq_0'[OF this, of max] show "finite {t. max (fun1 t) (fun2 t) ≠ 0}"
by (auto simp: max_def)
qed
lemma adds_poly_mappingI:
assumes "lookup s ≤ lookup (t::'a ⇒⇩0 'b)"
shows "s adds t"
unfolding poly_mapping_adds_iff using assms by (rule adds_funI)
lemma lookup_lcs_fun: "lookup (lcs s t) = lcs (lookup s) (lookup (t:: 'a ⇒⇩0 'b))"
by (simp only: lcs_poly_mapping.rep_eq lcs_fun_def)
instance
by (standard, simp_all only: poly_mapping_adds_iff lookup_lcs_fun, rule adds_lcs, elim lcs_adds,
assumption, rule poly_mapping_eqI, simp only: lookup_lcs_fun lcs_comm)
end
lemma adds_poly_mapping: "s adds t ⟷ lookup s ≤ lookup t"
for s t::"'a ⇒⇩0 'b::add_linorder_min"
by (simp only: poly_mapping_adds_iff adds_fun)
lemma lookup_gcs_fun: "lookup (gcs s (t::'a ⇒⇩0 ('b::add_linorder))) = gcs (lookup s) (lookup t)"
proof
fix x
show "lookup (gcs s t) x = gcs (lookup s) (lookup t) x"
by (simp add: gcs_def lookup_minus lookup_add lookup_lcs_fun)
qed
subsubsection ‹@{typ "('a, 'b) poly_mapping"} belongs to class @{class ulcs_powerprod}›
instance poly_mapping :: (type, add_linorder_min) ulcs_powerprod ..
subsubsection ‹Power-products in a given set of indeterminates.›
lemma adds_except:
"s adds t = (except s V adds except t V ∧ except s (- V) adds except t (- V))"
for s t :: "'a ⇒⇩0 'b::add_linorder"
by (simp add: poly_mapping_adds_iff adds_except_fun[of "lookup s", where V=V] except.rep_eq)
lemma adds_except_singleton:
"s adds t ⟷ (except s {v} adds except t {v} ∧ lookup s v adds lookup t v)"
for s t :: "'a ⇒⇩0 'b::add_linorder"
by (simp add: poly_mapping_adds_iff adds_except_fun_singleton[of "lookup s", where v=v] except.rep_eq)
subsubsection ‹Dickson's lemma for power-products in finitely many indeterminates›
context countable
begin
definition elem_index :: "'a ⇒ nat" where "elem_index = (SOME f. inj f)"
lemma inj_elem_index: "inj elem_index"
unfolding elem_index_def using ex_inj by (rule someI_ex)
lemma elem_index_inj:
assumes "elem_index x = elem_index y"
shows "x = y"
using inj_elem_index assms by (rule injD)
lemma finite_nat_seg: "finite {x. elem_index x < n}"
proof (rule finite_imageD)
have "elem_index ` {x. elem_index x < n} ⊆ {0..<n}" by auto
moreover have "finite ..." ..
ultimately show "finite (elem_index ` {x. elem_index x < n})" by (rule finite_subset)
next
from inj_elem_index show "inj_on elem_index {x. elem_index x < n}" using inj_on_subset by blast
qed
end
lemma Dickson_poly_mapping:
assumes "finite V"
shows "almost_full_on (adds) {x::'a ⇒⇩0 'b::add_wellorder. keys x ⊆ V}"
proof (rule almost_full_onI)
fix seq::"nat ⇒ 'a ⇒⇩0 'b"
assume a: "∀i. seq i ∈ {x::'a ⇒⇩0 'b. keys x ⊆ V}"
define seq' where "seq' = (λi. lookup (seq i))"
from assms have "almost_full_on (adds) {x::'a ⇒ 'b. supp_fun x ⊆ V}" by (rule Dickson_fun)
moreover from a have "⋀i. seq' i ∈ {x::'a ⇒ 'b. supp_fun x ⊆ V}"
by (auto simp: seq'_def keys_eq_supp)
ultimately obtain i j where "i < j" and "seq' i adds seq' j" by (rule almost_full_onD)
from this(2) have "seq i adds seq j" by (simp add: seq'_def poly_mapping_adds_iff)
with ‹i < j› show "good (adds) seq" by (rule goodI)
qed
definition varnum :: "'x set ⇒ ('x::countable ⇒⇩0 'b::zero) ⇒ nat"
where "varnum X t = (if keys t - X = {} then 0 else Suc (Max (elem_index ` (keys t - X))))"
lemma elem_index_less_varnum:
assumes "x ∈ keys t"
obtains "x ∈ X" | "elem_index x < varnum X t"
proof (cases "x ∈ X")
case True
thus ?thesis ..
next
case False
with assms have 1: "x ∈ keys t - X" by simp
hence "keys t - X ≠ {}" by blast
hence eq: "varnum X t = Suc (Max (elem_index ` (keys t - X)))" by (simp add: varnum_def)
hence "elem_index x < varnum X t" using 1 by (simp add: less_Suc_eq_le)
thus ?thesis ..
qed
lemma varnum_plus:
"varnum X (s + t) = max (varnum X s) (varnum X (t::'x::countable ⇒⇩0 'b::ninv_comm_monoid_add))"
proof (simp add: varnum_def keys_plus_ninv_comm_monoid_add image_Un Un_Diff del: Diff_eq_empty_iff, intro impI)
assume 1: "keys s - X ≠ {}" and 2: "keys t - X ≠ {}"
have "finite (elem_index ` (keys s - X))" by simp
moreover from 1 have "elem_index ` (keys s - X) ≠ {}" by simp
moreover have "finite (elem_index ` (keys t - X))" by simp
moreover from 2 have "elem_index ` (keys t - X) ≠ {}" by simp
ultimately show "Max (elem_index ` (keys s - X) ∪ elem_index ` (keys t - X)) =
max (Max (elem_index ` (keys s - X))) (Max (elem_index ` (keys t - X)))"
by (rule Max_Un)
qed
lemma dickson_grading_varnum:
assumes "finite X"
shows "dickson_grading ((varnum X)::('x::countable ⇒⇩0 'b::add_wellorder) ⇒ nat)"
using varnum_plus
proof (rule dickson_gradingI)
fix m::nat
let ?V = "X ∪ {x. elem_index x < m}"
have "{t::'x ⇒⇩0 'b. varnum X t ≤ m} ⊆ {t. keys t ⊆ ?V}"
proof (rule, simp, intro subsetI, simp)
fix t::"'x ⇒⇩0 'b" and x::'x
assume "varnum X t ≤ m"
assume "x ∈ keys t"
thus "x ∈ X ∨ elem_index x < m"
proof (rule elem_index_less_varnum)
assume "x ∈ X"
thus ?thesis ..
next
assume "elem_index x < varnum X t"
hence "elem_index x < m" using ‹varnum X t ≤ m› by (rule less_le_trans)
thus ?thesis ..
qed
qed
thus "almost_full_on (adds) {t::'x ⇒⇩0 'b. varnum X t ≤ m}"
proof (rule almost_full_on_subset)
from assms finite_nat_seg have "finite ?V" by (rule finite_UnI)
thus "almost_full_on (adds) {t::'x ⇒⇩0 'b. keys t ⊆ ?V}" by (rule Dickson_poly_mapping)
qed
qed
corollary dickson_grading_varnum_empty:
"dickson_grading ((varnum {})::(_ ⇒⇩0 _::add_wellorder) ⇒ nat)"
using finite.emptyI by (rule dickson_grading_varnum)
lemma varnum_le_iff: "varnum X t ≤ n ⟷ keys t ⊆ X ∪ {x. elem_index x < n}"
by (auto simp: varnum_def Suc_le_eq)
lemma varnum_zero [simp]: "varnum X 0 = 0"
by (simp add: varnum_def)
lemma varnum_empty_eq_zero_iff: "varnum {} t = 0 ⟷ t = 0"
proof
assume "varnum {} t = 0"
hence "keys t = {}" by (simp add: varnum_def split: if_splits)
thus "t = 0" by (rule poly_mapping_eq_zeroI)
qed simp
instance poly_mapping :: (countable, add_wellorder) graded_dickson_powerprod
by standard (rule, fact dickson_grading_varnum_empty)
instance poly_mapping :: (finite, add_wellorder) dickson_powerprod
proof
have "finite (UNIV::'a set)" by simp
hence "almost_full_on (adds) {x::'a ⇒⇩0 'b. keys x ⊆ UNIV}" by (rule Dickson_poly_mapping)
thus "almost_full_on (adds) (UNIV::('a ⇒⇩0 'b) set)" by simp
qed
subsubsection ‹Lexicographic Term Order›
definition lex_pm :: "('a ⇒⇩0 'b) ⇒ ('a::linorder ⇒⇩0 'b::{zero,linorder}) ⇒ bool"
where "lex_pm = (≤)"
definition lex_pm_strict :: "('a ⇒⇩0 'b) ⇒ ('a::linorder ⇒⇩0 'b::{zero,linorder}) ⇒ bool"
where "lex_pm_strict = (<)"
lemma lex_pm_alt: "lex_pm s t = (s = t ∨ (∃x. lookup s x < lookup t x ∧ (∀y<x. lookup s y = lookup t y)))"
unfolding lex_pm_def by (metis less_eq_poly_mapping.rep_eq less_funE less_funI poly_mapping_eq_iff)
lemma lex_pm_refl: "lex_pm s s"
by (simp add: lex_pm_def)
lemma lex_pm_antisym: "lex_pm s t ⟹ lex_pm t s ⟹ s = t"
by (simp add: lex_pm_def)
lemma lex_pm_trans: "lex_pm s t ⟹ lex_pm t u ⟹ lex_pm s u"
by (simp add: lex_pm_def)
lemma lex_pm_lin: "lex_pm s t ∨ lex_pm t s"
by (simp add: lex_pm_def linear)
corollary lex_pm_strict_alt [code]: "lex_pm_strict s t = (¬ lex_pm t s)"
by (auto simp: lex_pm_strict_def lex_pm_def)
lemma lex_pm_zero_min: "lex_pm 0 s" for s::"_ ⇒⇩0 _::add_linorder_min"
proof (rule ccontr)
assume "¬ lex_pm 0 s"
hence "lex_pm_strict s 0" by (simp add: lex_pm_strict_alt)
thus False by (simp add: lex_pm_strict_def less_poly_mapping.rep_eq less_fun_def)
qed
lemma lex_pm_plus_monotone: "lex_pm s t ⟹ lex_pm (s + u) (t + u)"
for s t::"_ ⇒⇩0 _::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
by (simp add: lex_pm_def add_right_mono)
subsubsection ‹Degree›
lift_definition deg_pm::"('a ⇒⇩0 'b::comm_monoid_add) ⇒ 'b" is deg_fun .
lemma deg_pm_zero[simp]: "deg_pm 0 = 0"
by (simp add: deg_pm.rep_eq lookup_zero_fun)
lemma deg_pm_eq_0_iff[simp]: "deg_pm s = 0 ⟷ s = 0" for s::"'a ⇒⇩0 'b::add_linorder_min"
by (simp only: deg_pm.rep_eq poly_mapping_eq_iff lookup_zero_fun, rule deg_fun_eq_0_iff,
simp add: keys_eq_supp[symmetric])
lemma deg_pm_superset:
assumes "keys s ⊆ A" and "finite A"
shows "deg_pm s = (∑x∈A. lookup s x)"
using assms by (simp only: deg_pm.rep_eq keys_eq_supp, elim deg_fun_superset)
lemma deg_pm_plus: "deg_pm (s + t) = deg_pm s + deg_pm (t::'a ⇒⇩0 'b::comm_monoid_add)"
by (simp only: deg_pm.rep_eq lookup_plus_fun, rule deg_fun_plus, simp_all add: keys_eq_supp[symmetric])
lemma deg_pm_single: "deg_pm (Poly_Mapping.single x k) = k"
proof -
have "keys (Poly_Mapping.single x k) ⊆ {x}" by simp
moreover have "finite {x}" by simp
ultimately have "deg_pm (Poly_Mapping.single x k) = (∑y∈{x}. lookup (Poly_Mapping.single x k) y)"
by (rule deg_pm_superset)
also have "... = k" by simp
finally show ?thesis .
qed
subsubsection ‹General Degree-Orders›
context linorder
begin
lift_definition dord_pm::"(('a ⇒⇩0 'b::ordered_comm_monoid_add) ⇒ ('a ⇒⇩0 'b) ⇒ bool) ⇒ ('a ⇒⇩0 'b) ⇒ ('a ⇒⇩0 'b) ⇒ bool"
is dord_fun by (metis local.dord_fun_def)
lemma dord_pm_alt: "dord_pm ord = (λx y. deg_pm x < deg_pm y ∨ (deg_pm x = deg_pm y ∧ ord x y))"
by (intro ext) (transfer, simp add: dord_fun_def Let_def)
lemma dord_pm_degD:
assumes "dord_pm ord s t"
shows "deg_pm s ≤ deg_pm t"
using assms by (simp only: dord_pm.rep_eq deg_pm.rep_eq, elim dord_fun_degD)
lemma dord_pm_refl:
assumes "ord s s"
shows "dord_pm ord s s"
using assms by (simp only: dord_pm.rep_eq, intro dord_fun_refl, simp add: lookup_inverse)
lemma dord_pm_antisym:
assumes "ord s t ⟹ ord t s ⟹ s = t" and "dord_pm ord s t" and "dord_pm ord t s"
shows "s = t"
using assms
proof (simp only: dord_pm.rep_eq poly_mapping_eq_iff)
assume 1: "(ord s t ⟹ ord t s ⟹ lookup s = lookup t)"
assume 2: "dord_fun (map_fun Abs_poly_mapping id ∘ ord ∘ Abs_poly_mapping) (lookup s) (lookup t)"
assume 3: "dord_fun (map_fun Abs_poly_mapping id ∘ ord ∘ Abs_poly_mapping) (lookup t) (lookup s)"
from _ 2 3 show "lookup s = lookup t" by (rule dord_fun_antisym, simp add: lookup_inverse 1)
qed
lemma dord_pm_trans:
assumes "ord s t ⟹ ord t u ⟹ ord s u" and "dord_pm ord s t" and "dord_pm ord t u"
shows "dord_pm ord s u"
using assms
proof (simp only: dord_pm.rep_eq poly_mapping_eq_iff)
assume 1: "(ord s t ⟹ ord t u ⟹ ord s u)"
assume 2: "dord_fun (map_fun Abs_poly_mapping id ∘ ord ∘ Abs_poly_mapping) (lookup s) (lookup t)"
assume 3: "dord_fun (map_fun Abs_poly_mapping id ∘ ord ∘ Abs_poly_mapping) (lookup t) (lookup u)"
from _ 2 3 show "dord_fun (map_fun Abs_poly_mapping id ∘ ord ∘ Abs_poly_mapping) (lookup s) (lookup u)"
by (rule dord_fun_trans, simp add: lookup_inverse 1)
qed
lemma dord_pm_lin:
"dord_pm ord s t ∨ dord_pm ord t s"
if "ord s t ∨ ord t s"
for s t::"'a ⇒⇩0 'b::{ordered_comm_monoid_add, linorder}"
using that by (simp only: dord_pm.rep_eq, intro dord_fun_lin, simp add: lookup_inverse)
lemma dord_pm_zero_min: "dord_pm ord 0 s"
if ord_refl: "⋀t. ord t t"
for s t::"'a ⇒⇩0 'b::add_linorder_min"
using that
by (simp only: dord_pm.rep_eq lookup_zero_fun, intro dord_fun_zero_min,
simp add: lookup_inverse, simp add: keys_eq_supp[symmetric])
lemma dord_pm_plus_monotone:
fixes s t u ::"'a ⇒⇩0 'b::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
assumes "ord s t ⟹ ord (s + u) (t + u)" and "dord_pm ord s t"
shows "dord_pm ord (s + u) (t + u)"
using assms
by (simp only: dord_pm.rep_eq lookup_plus_fun, intro dord_fun_plus_monotone,
simp add: lookup_inverse lookup_plus_fun[symmetric],
simp add: keys_eq_supp[symmetric],
simp add: keys_eq_supp[symmetric],
simp add: keys_eq_supp[symmetric],
simp add: lookup_inverse)
end
subsubsection ‹Degree-Lexicographic Term Order›
definition dlex_pm::"('a::linorder ⇒⇩0 'b::{ordered_comm_monoid_add,linorder}) ⇒ ('a ⇒⇩0 'b) ⇒ bool"
where "dlex_pm ≡ dord_pm lex_pm"
definition "dlex_pm_strict s t ⟷ dlex_pm s t ∧ ¬ dlex_pm t s"
lemma dlex_pm_refl: "dlex_pm s s"
unfolding dlex_pm_def using lex_pm_refl by (rule dord_pm_refl)
lemma dlex_pm_antisym: "dlex_pm s t ⟹ dlex_pm t s ⟹ s = t"
unfolding dlex_pm_def using lex_pm_antisym by (rule dord_pm_antisym)
lemma dlex_pm_trans: "dlex_pm s t ⟹ dlex_pm t u ⟹ dlex_pm s u"
unfolding dlex_pm_def using lex_pm_trans by (rule dord_pm_trans)
lemma dlex_pm_lin: "dlex_pm s t ∨ dlex_pm t s"
unfolding dlex_pm_def using lex_pm_lin by (rule dord_pm_lin)
corollary dlex_pm_strict_alt [code]: "dlex_pm_strict s t = (¬ dlex_pm t s)"
unfolding dlex_pm_strict_def using dlex_pm_lin by auto
lemma dlex_pm_zero_min: "dlex_pm 0 s"
for s t::"(_ ⇒⇩0 _::add_linorder_min)"
unfolding dlex_pm_def using lex_pm_refl by (rule dord_pm_zero_min)
lemma dlex_pm_plus_monotone: "dlex_pm s t ⟹ dlex_pm (s + u) (t + u)"
for s t::"_ ⇒⇩0 _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}"
unfolding dlex_pm_def using lex_pm_plus_monotone by (rule dord_pm_plus_monotone)
subsubsection ‹Degree-Reverse-Lexicographic Term Order›
definition drlex_pm::"('a::linorder ⇒⇩0 'b::{ordered_comm_monoid_add,linorder}) ⇒ ('a ⇒⇩0 'b) ⇒ bool"
where "drlex_pm ≡ dord_pm (λs t. lex_pm t s)"
definition "drlex_pm_strict s t ⟷ drlex_pm s t ∧ ¬ drlex_pm t s"
lemma drlex_pm_refl: "drlex_pm s s"
unfolding drlex_pm_def using lex_pm_refl by (rule dord_pm_refl)
lemma drlex_pm_antisym: "drlex_pm s t ⟹ drlex_pm t s ⟹ s = t"
unfolding drlex_pm_def using lex_pm_antisym by (rule dord_pm_antisym)
lemma drlex_pm_trans: "drlex_pm s t ⟹ drlex_pm t u ⟹ drlex_pm s u"
unfolding drlex_pm_def using lex_pm_trans by (rule dord_pm_trans)
lemma drlex_pm_lin: "drlex_pm s t ∨ drlex_pm t s"
unfolding drlex_pm_def using lex_pm_lin by (rule dord_pm_lin)
corollary drlex_pm_strict_alt [code]: "drlex_pm_strict s t = (¬ drlex_pm t s)"
unfolding drlex_pm_strict_def using drlex_pm_lin by auto
lemma drlex_pm_zero_min: "drlex_pm 0 s"
for s t::"(_ ⇒⇩0 _::add_linorder_min)"
unfolding drlex_pm_def using lex_pm_refl by (rule dord_pm_zero_min)
lemma drlex_pm_plus_monotone: "drlex_pm s t ⟹ drlex_pm (s + u) (t + u)"
for s t::"_ ⇒⇩0 _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}"
unfolding drlex_pm_def using lex_pm_plus_monotone by (rule dord_pm_plus_monotone)
end
Theory More_Modules
theory More_Modules
imports HOL.Modules
begin
text ‹More facts about modules.›
section ‹Modules over Commutative Rings›
context module
begin
lemma scale_minus_both [simp]: "(- a) *s (- x) = a *s x"
by simp
subsection ‹Submodules Spanned by Sets of Module-Elements›
lemma span_insertI:
assumes "p ∈ span B"
shows "p ∈ span (insert r B)"
proof -
have "B ⊆ insert r B" by blast
hence "span B ⊆ span (insert r B)" by (rule span_mono)
with assms show ?thesis ..
qed
lemma span_insertD:
assumes "p ∈ span (insert r B)" and "r ∈ span B"
shows "p ∈ span B"
using assms(1)
proof (induct p rule: span_induct_alt)
case base
show "0 ∈ span B" by (fact span_zero)
next
case step: (step q b a)
from step(1) have "b = r ∨ b ∈ B" by simp
thus "q *s b + a ∈ span B"
proof
assume eq: "b = r"
from step(2) assms(2) show ?thesis unfolding eq by (intro span_add span_scale)
next
assume "b ∈ B"
hence "b ∈ span B" using span_superset ..
with step(2) show ?thesis by (intro span_add span_scale)
qed
qed
lemma span_insert_idI:
assumes "r ∈ span B"
shows "span (insert r B) = span B"
proof (intro subset_antisym subsetI)
fix p
assume "p ∈ span (insert r B)"
from this assms show "p ∈ span B" by (rule span_insertD)
next
fix p
assume "p ∈ span B"
thus "p ∈ span (insert r B)" by (rule span_insertI)
qed
lemma span_insert_zero: "span (insert 0 B) = span B"
using span_zero by (rule span_insert_idI)
lemma span_Diff_zero: "span (B - {0}) = span B"
by (metis span_insert_zero insert_Diff_single)
lemma span_insert_subset:
assumes "span A ⊆ span B" and "r ∈ span B"
shows "span (insert r A) ⊆ span B"
proof
fix p
assume "p ∈ span (insert r A)"
thus "p ∈ span B"
proof (induct p rule: span_induct_alt)
case base
show ?case by (fact span_zero)
next
case step: (step q b a)
show ?case
proof (intro span_add span_scale)
from ‹b ∈ insert r A› show "b ∈ span B"
proof
assume "b = r"
thus "b ∈ span B" using assms(2) by simp
next
assume "b ∈ A"
hence "b ∈ span A" using span_superset ..
thus "b ∈ span B" using assms(1) ..
qed
qed fact
qed
qed
lemma replace_span:
assumes "q ∈ span B"
shows "span (insert q (B - {p})) ⊆ span B"
by (rule span_insert_subset, rule span_mono, fact Diff_subset, fact)
lemma sum_in_spanI: "(∑b∈B. q b *s b) ∈ span B"
by (auto simp: intro: span_sum span_scale dest: span_base)
lemma span_closed_sum_list: "(⋀x. x ∈ set xs ⟹ x ∈ span B) ⟹ sum_list xs ∈ span B"
by (induct xs) (auto intro: span_zero span_add)
lemma spanE:
assumes "p ∈ span B"
obtains A q where "finite A" and "A ⊆ B" and "p = (∑b∈A. (q b) *s b)"
using assms by (auto simp: span_explicit)
lemma span_finite_subset:
assumes "p ∈ span B"
obtains A where "finite A" and "A ⊆ B" and "p ∈ span A"
proof -
from assms obtain A q where "finite A" and "A ⊆ B" and p: "p = (∑a∈A. q a *s a)"
by (rule spanE)
note this(1, 2)
moreover have "p ∈ span A" unfolding p by (rule sum_in_spanI)
ultimately show ?thesis ..
qed
lemma span_finiteE:
assumes "finite B" and "p ∈ span B"
obtains q where "p = (∑b∈B. (q b) *s b)"
using assms by (auto simp: span_finite)
lemma span_subset_spanI:
assumes "A ⊆ span B"
shows "span A ⊆ span B"
using assms subspace_span by (rule span_minimal)
lemma span_insert_cong:
assumes "span A = span B"
shows "span (insert p A) = span (insert p B)" (is "?l = ?r")
proof
have 1: "span (insert p C1) ⊆ span (insert p C2)" if "span C1 = span C2" for C1 C2
proof (rule span_subset_spanI)
show "insert p C1 ⊆ span (insert p C2)"
proof (rule insert_subsetI)
show "p ∈ span (insert p C2)" by (rule span_base) simp
next
have "C1 ⊆ span C1" by (rule span_superset)
also from that have "… = span C2" .
also have "… ⊆ span (insert p C2)" by (rule span_mono) blast
finally show "C1 ⊆ span (insert p C2)" .
qed
qed
from assms show "?l ⊆ ?r" by (rule 1)
from assms[symmetric] show "?r ⊆ ?l" by (rule 1)
qed
lemma span_induct' [consumes 1, case_names base step]:
assumes "p ∈ span B" and "P 0"
and "⋀a q p. a ∈ span B ⟹ P a ⟹ p ∈ B ⟹ q ≠ 0 ⟹ P (a + q *s p)"
shows "P p"
using assms(1, 1)
proof (induct p rule: span_induct_alt)
case base
from assms(2) show ?case .
next
case (step q b a)
from step.hyps(1) have "b ∈ span B" by (rule span_base)
hence "q *s b ∈ span B" by (rule span_scale)
with step.prems have "a ∈ span B" by (simp only: span_add_eq)
hence "P a" by (rule step.hyps)
show ?case
proof (cases "q = 0")
case True
from ‹P a› show ?thesis by (simp add: True)
next
case False
with ‹a ∈ span B› ‹P a› step.hyps(1) have "P (a + q *s b)" by (rule assms(3))
thus ?thesis by (simp only: add.commute)
qed
qed
lemma span_INT_subset: "span (⋂a∈A. f a) ⊆ (⋂a∈A. span (f a))" (is "?l ⊆ ?r")
proof
fix p
assume "p ∈ ?l"
show "p ∈ ?r"
proof
fix a
assume "a ∈ A"
from ‹p ∈ ?l› show "p ∈ span (f a)"
proof (induct p rule: span_induct')
case base
show ?case by (fact span_zero)
next
case (step p q b)
from step(3) ‹a ∈ A› have "b ∈ f a" ..
hence "b ∈ span (f a)" by (rule span_base)
with step(2) show ?case by (intro span_add span_scale)
qed
qed
qed
lemma span_INT: "span (⋂a∈A. span (f a)) = (⋂a∈A. span (f a))" (is "?l = ?r")
proof
have "?l ⊆ (⋂a∈A. span (span (f a)))" by (rule span_INT_subset)
also have "... = ?r" by (simp add: span_span)
finally show "?l ⊆ ?r" .
qed (fact span_superset)
lemma span_Int_subset: "span (A ∩ B) ⊆ span A ∩ span B"
proof -
have "span (A ∩ B) = span (⋂x∈{A, B}. x)" by simp
also have "… ⊆ (⋂x∈{A, B}. span x)" by (fact span_INT_subset)
also have "… = span A ∩ span B" by simp
finally show ?thesis .
qed
lemma span_Int: "span (span A ∩ span B) = span A ∩ span B"
proof -
have "span (span A ∩ span B) = span (⋂x∈{A, B}. span x)" by simp
also have "… = (⋂x∈{A, B}. span x)" by (fact span_INT)
also have "… = span A ∩ span B" by simp
finally show ?thesis .
qed
lemma span_image_scale_eq_image_scale: "span ((*s) q ` F) = (*s) q ` span F" (is "?A = ?B")
proof (intro subset_antisym subsetI)
fix p
assume "p ∈ ?A"
thus "p ∈ ?B"
proof (induct p rule: span_induct')
case base
from span_zero show ?case by (rule rev_image_eqI) simp
next
case (step p r a)
from step.hyps(2) obtain p' where "p' ∈ span F" and p: "p = q *s p'" ..
from step.hyps(3) obtain a' where "a' ∈ F" and a: "a = q *s a'" ..
from this(1) have "a' ∈ span F" by (rule span_base)
hence "r *s a' ∈ span F" by (rule span_scale)
with ‹p' ∈ span F› have "p' + r *s a' ∈ span F" by (rule span_add)
hence "q *s (p' + r *s a') ∈ ?B" by (rule imageI)
also have "q *s (p' + r *s a') = p + r *s a" by (simp add: a p algebra_simps)
finally show ?case .
qed
next
fix p
assume "p ∈ ?B"
then obtain p' where "p' ∈ span F" and "p = q *s p'" ..
from this(1) show "p ∈ ?A" unfolding ‹p = q *s p'›
proof (induct p' rule: span_induct')
case base
show ?case by (simp add: span_zero)
next
case (step p r a)
from step.hyps(3) have "q *s a ∈ (*s) q ` F" by (rule imageI)
hence "q *s a ∈ ?A" by (rule span_base)
hence "r *s (q *s a) ∈ ?A" by (rule span_scale)
with step.hyps(2) have "q *s p + r *s (q *s a) ∈ ?A" by (rule span_add)
also have "q *s p + r *s (q *s a) = q *s (p + r *s a)" by (simp add: algebra_simps)
finally show ?case .
qed
qed
end
section ‹Ideals over Commutative Rings›
lemma module_times: "module (*)"
by (standard, simp_all add: algebra_simps)
interpretation ideal: module times
by (fact module_times)
declare ideal.scale_scale[simp del]
abbreviation "ideal ≡ ideal.span"
lemma ideal_eq_UNIV_iff_contains_one: "ideal B = UNIV ⟷ 1 ∈ ideal B"
proof
assume *: "1 ∈ ideal B"
show "ideal B = UNIV"
proof
show "UNIV ⊆ ideal B"
proof
fix x
from * have "x * 1 ∈ ideal B" by (rule ideal.span_scale)
thus "x ∈ ideal B" by simp
qed
qed simp
qed simp
lemma ideal_eq_zero_iff [iff]: "ideal F = {0} ⟷ F ⊆ {0}"
by (metis empty_subsetI ideal.span_empty ideal.span_eq)
lemma ideal_field_cases:
obtains "ideal B = {0}" | "ideal (B::'a::field set) = UNIV"
proof (cases "ideal B = {0}")
case True
thus ?thesis ..
next
case False
hence "¬ B ⊆ {0}" by simp
then obtain b where "b ∈ B" and "b ≠ 0" by blast
from this(1) have "b ∈ ideal B" by (rule ideal.span_base)
hence "inverse b * b ∈ ideal B" by (rule ideal.span_scale)
with ‹b ≠ 0› have "ideal B = UNIV" by (simp add: ideal_eq_UNIV_iff_contains_one)
thus ?thesis ..
qed
corollary ideal_field_disj: "ideal B = {0} ∨ ideal (B::'a::field set) = UNIV"
by (rule ideal_field_cases) blast+
lemma image_ideal_subset:
assumes "⋀x y. h (x + y) = h x + h y" and "⋀x y. h (x * y) = h x * h y"
shows "h ` ideal F ⊆ ideal (h ` F)"
proof (intro subsetI, elim imageE)
fix g f
assume g: "g = h f"
assume "f ∈ ideal F"
thus "g ∈ ideal (h ` F)" unfolding g
proof (induct f rule: ideal.span_induct_alt)
case base
have "h 0 = h (0 + 0)" by simp
also have "… = h 0 + h 0" by (simp only: assms(1))
finally show ?case by (simp add: ideal.span_zero)
next
case (step c f g)
from step.hyps(1) have "h f ∈ ideal (h ` F)"
by (intro ideal.span_base imageI)
hence "h c * h f ∈ ideal (h ` F)" by (rule ideal.span_scale)
hence "h c * h f + h g ∈ ideal (h ` F)"
using step.hyps(2) by (rule ideal.span_add)
thus ?case by (simp only: assms)
qed
qed
lemma image_ideal_eq_surj:
assumes "⋀x y. h (x + y) = h x + h y" and "⋀x y. h (x * y) = h x * h y" and "surj h"
shows "h ` ideal B = ideal (h ` B)"
proof
from assms(1, 2) show "h ` ideal B ⊆ ideal (h ` B)" by (rule image_ideal_subset)
next
show "ideal (h ` B) ⊆ h ` ideal B"
proof
fix b
assume "b ∈ ideal (h ` B)"
thus "b ∈ h ` ideal B"
proof (induct b rule: ideal.span_induct_alt)
case base
have "h 0 = h (0 + 0)" by simp
also have "… = h 0 + h 0" by (simp only: assms(1))
finally have "0 = h 0" by simp
with ideal.span_zero show ?case by (rule rev_image_eqI)
next
case (step c b a)
from assms(3) obtain c' where c: "c = h c'" by (rule surjE)
from step.hyps(2) obtain a' where "a' ∈ ideal B" and a: "a = h a'" ..
from step.hyps(1) obtain b' where "b' ∈ B" and b: "b = h b'" ..
from this(1) have "b' ∈ ideal B" by (rule ideal.span_base)
hence "c' * b' ∈ ideal B" by (rule ideal.span_scale)
hence "c' * b' + a' ∈ ideal B" using ‹a' ∈ _› by (rule ideal.span_add)
moreover have "c * b + a = h (c' * b' + a')"
by (simp add: c b a assms(1, 2))
ultimately show ?case by (rule rev_image_eqI)
qed
qed
qed
context
fixes h :: "'a ⇒ 'a::comm_ring_1"
assumes h_plus: "h (x + y) = h x + h y"
assumes h_times: "h (x * y) = h x * h y"
assumes h_idem: "h (h x) = h x"
begin
lemma in_idealE_homomorphism_finite:
assumes "finite B" and "B ⊆ range h" and "p ∈ range h" and "p ∈ ideal B"
obtains q where "⋀b. q b ∈ range h" and "p = (∑b∈B. q b * b)"
proof -
from assms(1, 4) obtain q0 where p: "p = (∑b∈B. q0 b * b)" by (rule ideal.span_finiteE)
define q where "q = (λb. h (q0 b))"
show ?thesis
proof
fix b
show "q b ∈ range h" unfolding q_def by (rule rangeI)
next
from assms(3) obtain p' where "p = h p'" ..
hence "p = h p" by (simp only: h_idem)
also from ‹finite B› have "… = (∑b∈B. q b * h b)" unfolding p
proof (induct B)
case empty
have "h 0 = h (0 + 0)" by simp
also have "… = h 0 + h 0" by (simp only: h_plus)
finally show ?case by simp
next
case (insert b B)
thus ?case by (simp add: h_plus h_times q_def)
qed
also from refl have "… = (∑b∈B. q b * b)"
proof (rule sum.cong)
fix b
assume "b ∈ B"
hence "b ∈ range h" using assms(2) ..
then obtain b' where "b = h b'" ..
thus "q b * h b = q b * b" by (simp only: h_idem)
qed
finally show "p = (∑b∈B. q b * b)" .
qed
qed
corollary in_idealE_homomorphism:
assumes "B ⊆ range h" and "p ∈ range h" and "p ∈ ideal B"
obtains A q where "finite A" and "A ⊆ B" and "⋀b. q b ∈ range h" and "p = (∑b∈A. q b * b)"
proof -
from assms(3) obtain A where "finite A" and "A ⊆ B" and "p ∈ ideal A"
by (rule ideal.span_finite_subset)
from this(2) assms(1) have "A ⊆ range h" by (rule subset_trans)
with ‹finite A› obtain q where "⋀b. q b ∈ range h" and "p = (∑b∈A. q b * b)"
using assms(2) ‹p ∈ ideal A› by (rule in_idealE_homomorphism_finite) blast
with ‹finite A› ‹A ⊆ B› show ?thesis ..
qed
lemma ideal_induct_homomorphism [consumes 3, case_names 0 plus]:
assumes "B ⊆ range h" and "p ∈ range h" and "p ∈ ideal B"
assumes "P 0" and "⋀c b a. c ∈ range h ⟹ b ∈ B ⟹ P a ⟹ a ∈ range h ⟹ P (c * b + a)"
shows "P p"
proof -
from assms(1-3) obtain A q where "finite A" and "A ⊆ B" and rl: "⋀f. q f ∈ range h"
and p: "p = (∑f∈A. q f * f)" by (rule in_idealE_homomorphism) blast
show ?thesis unfolding p using ‹finite A› ‹A ⊆ B›
proof (induct A)
case empty
from assms(4) show ?case by simp
next
case (insert a A)
from insert.hyps(1, 2) have "(∑f∈insert a A. q f * f) = q a * a + (∑f∈A. q f * f)" by simp
also from rl have "P …"
proof (rule assms(5))
have "a ∈ insert a A" by simp
thus "a ∈ B" using insert.prems ..
next
from insert.prems have "A ⊆ B" by simp
thus "P (∑f∈A. q f * f)" by (rule insert.hyps)
next
from insert.prems have "A ⊆ B" by simp
hence "A ⊆ range h" using assms(1) by (rule subset_trans)
with ‹finite A› show "(∑f∈A. q f * f) ∈ range h"
proof (induct A)
case empty
have "h 0 = h (0 + 0)" by simp
also have "… = h 0 + h 0" by (simp only: h_plus)
finally have "(∑f∈{}. q f * f) = h 0" by simp
thus ?case by (rule image_eqI) simp
next
case (insert a A)
from insert.prems have "a ∈ range h" and "A ⊆ range h" by simp_all
from this(1) obtain a' where a: "a = h a'" ..
from ‹q a ∈ range h› obtain q' where q: "q a = h q'" ..
from ‹A ⊆ _› have "(∑f∈A. q f * f) ∈ range h" by (rule insert.hyps)
then obtain m where eq: "(∑f∈A. q f * f) = h m" ..
from insert.hyps(1, 2) have "(∑f∈insert a A. q f * f) = q a * a + (∑f∈A. q f * f)" by simp
also have "… = h (q' * a' + m)" unfolding q by (simp add: a eq h_plus h_times)
also have "… ∈ range h" by (rule rangeI)
finally show ?case .
qed
qed
finally show ?case .
qed
qed
lemma image_ideal_eq_Int: "h ` ideal B = ideal (h ` B) ∩ range h"
proof
from h_plus h_times have "h ` ideal B ⊆ ideal (h ` B)" by (rule image_ideal_subset)
thus "h ` ideal B ⊆ ideal (h ` B) ∩ range h" by blast
next
show "ideal (h ` B) ∩ range h ⊆ h ` ideal B"
proof
fix b
assume "b ∈ ideal (h ` B) ∩ range h"
hence "b ∈ ideal (h ` B)" and "b ∈ range h" by simp_all
have "h ` B ⊆ range h" by blast
thus "b ∈ h ` ideal B" using ‹b ∈ range h› ‹b ∈ ideal (h ` B)›
proof (induct b rule: ideal_induct_homomorphism)
case 0
have "h 0 = h (0 + 0)" by simp
also have "… = h 0 + h 0" by (simp only: h_plus)
finally have "0 = h 0" by simp
with ideal.span_zero show ?case by (rule rev_image_eqI)
next
case (plus c b a)
from plus.hyps(1) obtain c' where c: "c = h c'" ..
from plus.hyps(3) obtain a' where "a' ∈ ideal B" and a: "a = h a'" ..
from plus.hyps(2) obtain b' where "b' ∈ B" and b: "b = h b'" ..
from this(1) have "b' ∈ ideal B" by (rule ideal.span_base)
hence "c' * b' ∈ ideal B" by (rule ideal.span_scale)
hence "c' * b' + a' ∈ ideal B" using ‹a' ∈ _› by (rule ideal.span_add)
moreover have "c * b + a = h (c' * b' + a')" by (simp add: a b c h_plus h_times)
ultimately show ?case by (rule rev_image_eqI)
qed
qed
qed
end
end
Theory MPoly_Type_Class
section ‹Type-Class-Multivariate Polynomials›
theory MPoly_Type_Class
imports
Utils
Power_Products
More_Modules
begin
text ‹This theory views @{typ "'a ⇒⇩0 'b"} as multivariate polynomials, where type class constraints
on @{typ 'a} ensure that @{typ 'a} represents something like monomials.›
lemma when_distrib: "f (a when b) = (f a when b)" if "¬ b ⟹ f 0 = 0"
using that by (auto simp: when_def)
definition mapp_2 :: "('a ⇒ 'b ⇒ 'c ⇒ 'd) ⇒ ('a ⇒⇩0 'b::zero) ⇒ ('a ⇒⇩0 'c::zero) ⇒ ('a ⇒⇩0 'd::zero)"
where "mapp_2 f p q = Abs_poly_mapping (λk. f k (lookup p k) (lookup q k) when k ∈ keys p ∪ keys q)"
lemma lookup_mapp_2:
"lookup (mapp_2 f p q) k = (f k (lookup p k) (lookup q k) when k ∈ keys p ∪ keys q)"
proof -
have "lookup (Abs_poly_mapping (λk. f k (lookup p k) (lookup q k) when k ∈ keys p ∪ keys q)) =
(λk. f k (lookup p k) (lookup q k) when k ∈ keys p ∪ keys q)"
by (rule Abs_poly_mapping_inverse, simp)
thus ?thesis by (simp add: mapp_2_def)
qed
lemma lookup_mapp_2_homogenous:
assumes "f k 0 0 = 0"
shows "lookup (mapp_2 f p q) k = f k (lookup p k) (lookup q k)"
by (simp add: lookup_mapp_2 when_def in_keys_iff assms)
lemma mapp_2_cong [fundef_cong]:
assumes "p = p'" and "q = q'"
assumes "⋀k. k ∈ keys p' ∪ keys q' ⟹ f k (lookup p' k) (lookup q' k) = f' k (lookup p' k) (lookup q' k)"
shows "mapp_2 f p q = mapp_2 f' p' q'"
by (rule poly_mapping_eqI, simp add: assms(1, 2) lookup_mapp_2, rule when_cong, fact refl, rule assms(3), blast)
lemma keys_mapp_subset: "keys (mapp_2 f p q) ⊆ keys p ∪ keys q"
proof
fix t
assume "t ∈ keys (mapp_2 f p q)"
hence "lookup (mapp_2 f p q) t ≠ 0" by (simp add: in_keys_iff)
thus "t ∈ keys p ∪ keys q" by (simp add: lookup_mapp_2 when_def split: if_split_asm)
qed
lemma mapp_2_mapp: "mapp_2 (λt a. f t) 0 p = Poly_Mapping.mapp f p"
by (rule poly_mapping_eqI, simp add: lookup_mapp lookup_mapp_2)
subsection ‹@{const keys}›
lemma in_keys_plusI1:
assumes "t ∈ keys p" and "t ∉ keys q"
shows "t ∈ keys (p + q)"
using assms unfolding in_keys_iff lookup_add by simp
lemma in_keys_plusI2:
assumes "t ∈ keys q" and "t ∉ keys p"
shows "t ∈ keys (p + q)"
using assms unfolding in_keys_iff lookup_add by simp
lemma keys_plus_eqI:
assumes "keys p ∩ keys q = {}"
shows "keys (p + q) = (keys p ∪ keys q)"
proof
show "keys (p + q) ⊆ keys p ∪ keys q"
by (simp add: Poly_Mapping.keys_add)
show "keys p ∪ keys q ⊆ keys (p + q)"
by (simp add: More_MPoly_Type.keys_add assms)
qed
lemma keys_uminus: "keys (- p) = keys p"
by (transfer, auto)
lemma keys_minus: "keys (p - q) ⊆ (keys p ∪ keys q)"
by (transfer, auto)
subsection ‹Monomials›
abbreviation "monomial ≡ (λc t. Poly_Mapping.single t c)"
lemma keys_of_monomial:
assumes "c ≠ 0"
shows "keys (monomial c t) = {t}"
using assms by simp
lemma monomial_uminus:
shows "- monomial c s = monomial (- c) s"
by (transfer, rule ext, simp add: Poly_Mapping.when_def)
lemma monomial_inj:
assumes "monomial c s = monomial (d::'b::zero_neq_one) t"
shows "(c = 0 ∧ d = 0) ∨ (c = d ∧ s = t)"
using assms unfolding poly_mapping_eq_iff
by (metis (mono_tags, hide_lams) lookup_single_eq lookup_single_not_eq)
definition is_monomial :: "('a ⇒⇩0 'b::zero) ⇒ bool"
where "is_monomial p ⟷ card (keys p) = 1"
lemma monomial_is_monomial:
assumes "c ≠ 0"
shows "is_monomial (monomial c t)"
using keys_single[of t c] assms by (simp add: is_monomial_def)
lemma is_monomial_monomial:
assumes "is_monomial p"
obtains c t where "c ≠ 0" and "p = monomial c t"
proof -
from assms have "card (keys p) = 1" unfolding is_monomial_def .
then obtain t where sp: "keys p = {t}" by (rule card_1_singletonE)
let ?c = "lookup p t"
from sp have "?c ≠ 0" by fastforce
show ?thesis
proof
show "p = monomial ?c t"
proof (intro poly_mapping_keys_eqI)
from sp show "keys p = keys (monomial ?c t)" using ‹?c ≠ 0› by simp
next
fix s
assume "s ∈ keys p"
with sp have "s = t" by simp
show "lookup p s = lookup (monomial ?c t) s" by (simp add: ‹s = t›)
qed
qed fact
qed
lemma is_monomial_uminus: "is_monomial (-p) ⟷ is_monomial p"
unfolding is_monomial_def keys_uminus ..
lemma monomial_not_0:
assumes "is_monomial p"
shows "p ≠ 0"
using assms unfolding is_monomial_def by auto
lemma keys_subset_singleton_imp_monomial:
assumes "keys p ⊆ {t}"
shows "monomial (lookup p t) t = p"
proof (rule poly_mapping_eqI, simp add: lookup_single when_def, rule)
fix s
assume "t ≠ s"
hence "s ∉ keys p" using assms by blast
thus "lookup p s = 0" by (simp add: in_keys_iff)
qed
lemma monomial_0I:
assumes "c = 0"
shows "monomial c t = 0"
using assms by transfer (auto)
lemma monomial_0D:
assumes "monomial c t = 0"
shows "c = 0"
using assms by transfer (auto simp: fun_eq_iff when_def; meson)
corollary monomial_0_iff: "monomial c t = 0 ⟷ c = 0"
by (rule, erule monomial_0D, erule monomial_0I)
lemma lookup_times_monomial_left: "lookup (monomial c t * p) s = (c * lookup p (s - t) when t adds s)"
for c::"'b::semiring_0" and t::"'a::comm_powerprod"
proof (induct p rule: poly_mapping_except_induct, simp)
fix p::"'a ⇒⇩0 'b" and w
assume "p ≠ 0" and "w ∈ keys p"
and IH: "lookup (monomial c t * except p {w}) s =
(c * lookup (except p {w}) (s - t) when t adds s)" (is "_ = ?x")
have "monomial c t * p = monomial c t * (monomial (lookup p w) w + except p {w})"
by (simp only: plus_except[symmetric])
also have "... = monomial c t * monomial (lookup p w) w + monomial c t * except p {w}"
by (simp add: algebra_simps)
also have "... = monomial (c * lookup p w) (t + w) + monomial c t * except p {w}"
by (simp only: mult_single)
finally have "lookup (monomial c t * p) s = lookup (monomial (c * lookup p w) (t + w)) s + ?x"
by (simp only: lookup_add IH)
also have "... = (lookup (monomial (c * lookup p w) (t + w)) s +
c * lookup (except p {w}) (s - t) when t adds s)"
by (rule when_distrib, auto simp add: lookup_single when_def)
also from refl have "... = (c * lookup p (s - t) when t adds s)"
proof (rule when_cong)
assume "t adds s"
then obtain u where u: "s = t + u" ..
show "lookup (monomial (c * lookup p w) (t + w)) s + c * lookup (except p {w}) (s - t) =
c * lookup p (s - t)"
by (simp add: u, cases "u = w", simp_all add: lookup_except lookup_single add.commute)
qed
finally show "lookup (monomial c t * p) s = (c * lookup p (s - t) when t adds s)" .
qed
lemma lookup_times_monomial_right: "lookup (p * monomial c t) s = (lookup p (s - t) * c when t adds s)"
for c::"'b::semiring_0" and t::"'a::comm_powerprod"
proof (induct p rule: poly_mapping_except_induct, simp)
fix p::"'a ⇒⇩0 'b" and w
assume "p ≠ 0" and "w ∈ keys p"
and IH: "lookup (except p {w} * monomial c t) s =
((lookup (except p {w}) (s - t)) * c when t adds s)"
(is "_ = ?x")
have "p * monomial c t = (monomial (lookup p w) w + except p {w}) * monomial c t"
by (simp only: plus_except[symmetric])
also have "... = monomial (lookup p w) w * monomial c t + except p {w} * monomial c t"
by (simp add: algebra_simps)
also have "... = monomial (lookup p w * c) (w + t) + except p {w} * monomial c t"
by (simp only: mult_single)
finally have "lookup (p * monomial c t) s = lookup (monomial (lookup p w * c) (w + t)) s + ?x"
by (simp only: lookup_add IH)
also have "... = (lookup (monomial (lookup p w * c) (w + t)) s +
lookup (except p {w}) (s - t) * c when t adds s)"
by (rule when_distrib, auto simp add: lookup_single when_def)
also from refl have "... = (lookup p (s - t) * c when t adds s)"
proof (rule when_cong)
assume "t adds s"
then obtain u where u: "s = t + u" ..
show "lookup (monomial (lookup p w * c) (w + t)) s + lookup (except p {w}) (s - t) * c =
lookup p (s - t) * c"
by (simp add: u, cases "u = w", simp_all add: lookup_except lookup_single add.commute)
qed
finally show "lookup (p * monomial c t) s = (lookup p (s - t) * c when t adds s)" .
qed
subsection ‹Vector-Polynomials›
text ‹From now on we consider multivariate vector-polynomials, i.\,e. vectors of scalar polynomials.
We do this by adding a @{emph ‹component›} to each power-product, yielding
@{emph ‹terms›}. Vector-polynomials are then again just linear combinations of terms.
Note that a term is @{emph ‹not›} the same as a vector of power-products!›
text ‹We use define terms in a locale, such that later on we can interpret the
locale also by ordinary power-products (without components), exploiting the canonical isomorphism
between @{typ 'a} and @{typ ‹'a × unit›}.›
named_theorems term_simps "simplification rules for terms"
locale term_powerprod =
fixes pair_of_term::"'t ⇒ ('a::comm_powerprod × 'k::linorder)"
fixes term_of_pair::"('a × 'k) ⇒ 't"
assumes term_pair [term_simps]: "term_of_pair (pair_of_term v) = v"
assumes pair_term [term_simps]: "pair_of_term (term_of_pair p) = p"
begin
lemma pair_of_term_injective:
assumes "pair_of_term u = pair_of_term v"
shows "u = v"
proof -
from assms have "term_of_pair (pair_of_term u) = term_of_pair (pair_of_term v)" by (simp only:)
thus ?thesis by (simp add: term_simps)
qed
corollary pair_of_term_inj: "inj pair_of_term"
using pair_of_term_injective by (rule injI)
lemma term_of_pair_injective:
assumes "term_of_pair p = term_of_pair q"
shows "p = q"
proof -
from assms have "pair_of_term (term_of_pair p) = pair_of_term (term_of_pair q)" by (simp only:)
thus ?thesis by (simp add: term_simps)
qed
corollary term_of_pair_inj: "inj term_of_pair"
using term_of_pair_injective by (rule injI)
definition pp_of_term :: "'t ⇒ 'a"
where "pp_of_term v = fst (pair_of_term v)"
definition component_of_term :: "'t ⇒ 'k"
where "component_of_term v = snd (pair_of_term v)"
lemma term_of_pair_pair [term_simps]: "term_of_pair (pp_of_term v, component_of_term v) = v"
by (simp add: pp_of_term_def component_of_term_def term_pair)
lemma pp_of_term_of_pair [term_simps]: "pp_of_term (term_of_pair (t, k)) = t"
by (simp add: pp_of_term_def pair_term)
lemma component_of_term_of_pair [term_simps]: "component_of_term (term_of_pair (t, k)) = k"
by (simp add: component_of_term_def pair_term)
subsubsection ‹Additive Structure of Terms›
definition splus :: "'a ⇒ 't ⇒ 't" (infixl "⊕" 75)
where "splus t v = term_of_pair (t + pp_of_term v, component_of_term v)"
definition sminus :: "'t ⇒ 'a ⇒ 't" (infixl "⊖" 75)
where "sminus v t = term_of_pair (pp_of_term v - t, component_of_term v)"
text ‹Note that the argument order in @{const sminus} is reversed compared to the order in @{const splus}.›
definition adds_pp :: "'a ⇒ 't ⇒ bool" (infix "adds⇩p" 50)
where "adds_pp t v ⟷ t adds pp_of_term v"
definition adds_term :: "'t ⇒ 't ⇒ bool" (infix "adds⇩t" 50)
where "adds_term u v ⟷ component_of_term u = component_of_term v ∧ pp_of_term u adds pp_of_term v"
lemma pp_of_term_splus [term_simps]: "pp_of_term (t ⊕ v) = t + pp_of_term v"
by (simp add: splus_def term_simps)
lemma component_of_term_splus [term_simps]: "component_of_term (t ⊕ v) = component_of_term v"
by (simp add: splus_def term_simps)
lemma pp_of_term_sminus [term_simps]: "pp_of_term (v ⊖ t) = pp_of_term v - t"
by (simp add: sminus_def term_simps)
lemma component_of_term_sminus [term_simps]: "component_of_term (v ⊖ t) = component_of_term v"
by (simp add: sminus_def term_simps)
lemma splus_sminus [term_simps]: "(t ⊕ v) ⊖ t = v"
by (simp add: sminus_def term_simps)
lemma splus_zero [term_simps]: "0 ⊕ v = v"
by (simp add: splus_def term_simps)
lemma sminus_zero [term_simps]: "v ⊖ 0 = v"
by (simp add: sminus_def term_simps)
lemma splus_assoc [ac_simps]: "(s + t) ⊕ v = s ⊕ (t ⊕ v)"
by (simp add: splus_def ac_simps term_simps)
lemma splus_left_commute [ac_simps]: "s ⊕ (t ⊕ v) = t ⊕ (s ⊕ v)"
by (simp add: splus_def ac_simps term_simps)
lemma splus_right_canc [term_simps]: "t ⊕ v = s ⊕ v ⟷ t = s"
by (metis add_right_cancel pp_of_term_splus)
lemma splus_left_canc [term_simps]: "t ⊕ v = t ⊕ u ⟷ v = u"
by (metis splus_sminus)
lemma adds_ppI [intro?]:
assumes "v = t ⊕ u"
shows "t adds⇩p v"
by (simp add: adds_pp_def assms splus_def term_simps)
lemma adds_ppE [elim?]:
assumes "t adds⇩p v"
obtains u where "v = t ⊕ u"
proof -
from assms obtain s where *: "pp_of_term v = t + s" unfolding adds_pp_def ..
have "v = t ⊕ (term_of_pair (s, component_of_term v))"
by (simp add: splus_def term_simps, metis * add.commute term_of_pair_pair)
thus ?thesis ..
qed
lemma adds_pp_alt: "t adds⇩p v ⟷ (∃u. v = t ⊕ u)"
by (meson adds_ppE adds_ppI)
lemma adds_pp_refl [term_simps]: "(pp_of_term v) adds⇩p v"
by (simp add: adds_pp_def)
lemma adds_pp_trans [trans]:
assumes "s adds t" and "t adds⇩p v"
shows "s adds⇩p v"
proof -
note assms(1)
also from assms(2) have "t adds pp_of_term v" by (simp only: adds_pp_def)
finally show ?thesis by (simp only: adds_pp_def)
qed
lemma zero_adds_pp [term_simps]: "0 adds⇩p v"
by (simp add: adds_pp_def)
lemma adds_pp_splus:
assumes "t adds⇩p v"
shows "t adds⇩p s ⊕ v"
using assms by (simp add: adds_pp_def term_simps)
lemma adds_pp_triv [term_simps]: "t adds⇩p t ⊕ v"
by (simp add: adds_pp_def term_simps)
lemma plus_adds_pp_mono:
assumes "s adds t"
and "u adds⇩p v"
shows "s + u adds⇩p t ⊕ v"
using assms by (simp add: adds_pp_def term_simps) (rule plus_adds_mono)
lemma plus_adds_pp_left:
assumes "s + t adds⇩p v"
shows "s adds⇩p v"
using assms by (simp add: adds_pp_def plus_adds_left)
lemma plus_adds_pp_right:
assumes "s + t adds⇩p v"
shows "t adds⇩p v"
using assms by (simp add: adds_pp_def plus_adds_right)
lemma adds_pp_sminus:
assumes "t adds⇩p v"
shows "t ⊕ (v ⊖ t) = v"
proof -
from assms adds_pp_alt[of t v] obtain u where u: "v = t ⊕ u" by (auto simp: ac_simps)
hence "v ⊖ t = u" by (simp add: term_simps)
thus ?thesis using u by simp
qed
lemma adds_pp_canc: "t + s adds⇩p (t ⊕ v) ⟷ s adds⇩p v"
by (simp add: adds_pp_def adds_canc_2 term_simps)
lemma adds_pp_canc_2: "s + t adds⇩p (t ⊕ v) ⟷ s adds⇩p v"
by (simp add: adds_pp_canc add.commute[of s t])
lemma plus_adds_pp_0:
assumes "(s + t) adds⇩p v"
shows "s adds⇩p (v ⊖ t)"
using assms by (simp add: adds_pp_def term_simps) (rule plus_adds_0)
lemma plus_adds_ppI_1:
assumes "t adds⇩p v" and "s adds⇩p (v ⊖ t)"
shows "(s + t) adds⇩p v"
using assms by (simp add: adds_pp_def term_simps) (rule plus_adds_2)
lemma plus_adds_ppI_2:
assumes "t adds⇩p v" and "s adds⇩p (v ⊖ t)"
shows "(t + s) adds⇩p v"
unfolding add.commute[of t s] using assms by (rule plus_adds_ppI_1)
lemma plus_adds_pp: "(s + t) adds⇩p v ⟷ (t adds⇩p v ∧ s adds⇩p (v ⊖ t))"
by (simp add: adds_pp_def plus_adds term_simps)
lemma minus_splus:
assumes "s adds t"
shows "(t - s) ⊕ v = (t ⊕ v) ⊖ s"
by (simp add: assms minus_plus sminus_def splus_def term_simps)
lemma minus_splus_sminus:
assumes "s adds t" and "u adds⇩p v"
shows "(t - s) ⊕ (v ⊖ u) = (t ⊕ v) ⊖ (s + u)"
using assms minus_plus_minus term_powerprod.adds_pp_def term_powerprod_axioms sminus_def
splus_def term_simps by fastforce
lemma minus_splus_sminus_cancel:
assumes "s adds t" and "t adds⇩p v"
shows "(t - s) ⊕ (v ⊖ t) = v ⊖ s"
by (simp add: adds_pp_sminus assms minus_splus)
lemma sminus_plus:
assumes "s adds⇩p v" and "t adds⇩p (v ⊖ s)"
shows "v ⊖ (s + t) = (v ⊖ s) ⊖ t"
by (simp add: diff_diff_add sminus_def term_simps)
lemma adds_termI [intro?]:
assumes "v = t ⊕ u"
shows "u adds⇩t v"
by (simp add: adds_term_def assms splus_def term_simps)
lemma adds_termE [elim?]:
assumes "u adds⇩t v"
obtains t where "v = t ⊕ u"
proof -
from assms have eq: "component_of_term u = component_of_term v" and "pp_of_term u adds pp_of_term v"
by (simp_all add: adds_term_def)
from this(2) obtain s where *: "s + pp_of_term u = pp_of_term v" unfolding adds_term_def
using adds_minus by blast
have "v = s ⊕ u" by (simp add: splus_def eq * term_simps)
thus ?thesis ..
qed
lemma adds_term_alt: "u adds⇩t v ⟷ (∃t. v = t ⊕ u)"
by (meson adds_termE adds_termI)
lemma adds_term_refl [term_simps]: "v adds⇩t v"
by (simp add: adds_term_def)
lemma adds_term_trans [trans]:
assumes "u adds⇩t v" and "v adds⇩t w"
shows "u adds⇩t w"
using assms unfolding adds_term_def using adds_trans by auto
lemma adds_term_splus:
assumes "u adds⇩t v"
shows "u adds⇩t s ⊕ v"
using assms by (simp add: adds_term_def term_simps)
lemma adds_term_triv [term_simps]: "v adds⇩t t ⊕ v"
by (simp add: adds_term_def term_simps)
lemma splus_adds_term_mono:
assumes "s adds t"
and "u adds⇩t v"
shows "s ⊕ u adds⇩t t ⊕ v"
using assms by (auto simp: adds_term_def term_simps intro: plus_adds_mono)
lemma splus_adds_term:
assumes "t ⊕ u adds⇩t v"
shows "u adds⇩t v"
using assms by (auto simp add: adds_term_def term_simps elim: plus_adds_right)
lemma adds_term_adds_pp:
"u adds⇩t v ⟷ (component_of_term u = component_of_term v ∧ pp_of_term u adds⇩p v)"
by (simp add: adds_term_def adds_pp_def)
lemma adds_term_canc: "t ⊕ u adds⇩t t ⊕ v ⟷ u adds⇩t v"
by (simp add: adds_term_def adds_canc_2 term_simps)
lemma adds_term_canc_2: "s ⊕ v adds⇩t t ⊕ v ⟷ s adds t"
by (simp add: adds_term_def adds_canc term_simps)
lemma splus_adds_term_0:
assumes "t ⊕ u adds⇩t v"
shows "u adds⇩t (v ⊖ t)"
using assms by (simp add: adds_term_def add.commute[of t] term_simps) (auto intro: plus_adds_0)
lemma splus_adds_termI_1:
assumes "t adds⇩p v" and "u adds⇩t (v ⊖ t)"
shows "t ⊕ u adds⇩t v"
using assms apply (simp add: adds_term_def term_simps) by (metis add.commute adds_pp_def plus_adds_2)
lemma splus_adds_term_iff: "t ⊕ u adds⇩t v ⟷ (t adds⇩p v ∧ u adds⇩t (v ⊖ t))"
by (metis adds_ppI adds_pp_splus adds_termE splus_adds_termI_1 splus_adds_term_0)
lemma adds_minus_splus:
assumes "pp_of_term u adds t"
shows "(t - pp_of_term u) ⊕ u = term_of_pair (t, component_of_term u)"
by (simp add: splus_def adds_minus[OF assms])
subsubsection ‹Projections and Conversions›
lift_definition proj_poly :: "'k ⇒ ('t ⇒⇩0 'b) ⇒ ('a ⇒⇩0 'b::zero)"
is "λk p t. p (term_of_pair (t, k))"
proof -
fix k::'k and p::"'t ⇒ 'b"
assume fin: "finite {v. p v ≠ 0}"
have "{t. p (term_of_pair (t, k)) ≠ 0} ⊆ pp_of_term ` {v. p v ≠ 0}"
proof (rule, simp)
fix t
assume "p (term_of_pair (t, k)) ≠ 0"
hence *: "term_of_pair (t, k) ∈ {v. p v ≠ 0}" by simp
have "t = pp_of_term (term_of_pair (t, k))" by (simp add: pp_of_term_def pair_term)
from this * show "t ∈ pp_of_term ` {v. p v ≠ 0}" ..
qed
moreover from fin have "finite (pp_of_term ` {v. p v ≠ 0})" by (rule finite_imageI)
ultimately show "finite {t. p (term_of_pair (t, k)) ≠ 0}" by (rule finite_subset)
qed
definition vectorize_poly :: "('t ⇒⇩0 'b) ⇒ ('k ⇒⇩0 ('a ⇒⇩0 'b::zero))"
where "vectorize_poly p = Abs_poly_mapping (λk. proj_poly k p)"
definition atomize_poly :: "('k ⇒⇩0 ('a ⇒⇩0 'b)) ⇒ ('t ⇒⇩0 'b::zero)"
where "atomize_poly p = Abs_poly_mapping (λv. lookup (lookup p (component_of_term v)) (pp_of_term v))"
lemma lookup_proj_poly: "lookup (proj_poly k p) t = lookup p (term_of_pair (t, k))"
by (transfer, simp)
lemma lookup_vectorize_poly: "lookup (vectorize_poly p) k = proj_poly k p"
proof -
have "lookup (Abs_poly_mapping (λk. proj_poly k p)) = (λk. proj_poly k p)"
proof (rule Abs_poly_mapping_inverse, simp)
have "{k. proj_poly k p ≠ 0} ⊆ component_of_term ` keys p"
proof (rule, simp)
fix k
assume "proj_poly k p ≠ 0"
hence "keys (proj_poly k p) ≠ {}" using poly_mapping_eq_zeroI by blast
then obtain t where "lookup (proj_poly k p) t ≠ 0" by blast
hence "term_of_pair (t, k) ∈ keys p" by (simp add: lookup_proj_poly in_keys_iff)
hence "component_of_term (term_of_pair (t, k)) ∈ component_of_term ` keys p" by fastforce
thus "k ∈ component_of_term ` keys p" by (simp add: term_simps)
qed
moreover from finite_keys have "finite (component_of_term ` keys p)" by (rule finite_imageI)
ultimately show "finite {k. proj_poly k p ≠ 0}" by (rule finite_subset)
qed
thus ?thesis by (simp add: vectorize_poly_def)
qed
lemma lookup_atomize_poly:
"lookup (atomize_poly p) v = lookup (lookup p (component_of_term v)) (pp_of_term v)"
proof -
have "lookup (Abs_poly_mapping (λv. lookup (lookup p (component_of_term v)) (pp_of_term v))) =
(λv. lookup (lookup p (component_of_term v)) (pp_of_term v))"
proof (rule Abs_poly_mapping_inverse, simp)
have "{v. pp_of_term v ∈ keys (lookup p (component_of_term v))} ⊆
(⋃k∈keys p. (λt. term_of_pair (t, k)) ` keys (lookup p k))" (is "_ ⊆ ?A")
proof (rule, simp)
fix v
assume *: "pp_of_term v ∈ keys (lookup p (component_of_term v))"
hence "keys (lookup p (component_of_term v)) ≠ {}" by blast
hence "lookup p (component_of_term v) ≠ 0" by auto
hence "component_of_term v ∈ keys p" (is "?k ∈ _")
by (simp add: in_keys_iff)
thus "∃k∈keys p. v ∈ (λt. term_of_pair (t, k)) ` keys (lookup p k)"
proof
have "v = term_of_pair (pp_of_term v, component_of_term v)" by (simp add: term_simps)
from this * show "v ∈ (λt. term_of_pair (t, ?k)) ` keys (lookup p ?k)" ..
qed
qed
moreover have "finite ?A" by (rule, fact finite_keys, rule finite_imageI, rule finite_keys)
ultimately show "finite {x. lookup (lookup p (component_of_term x)) (pp_of_term x) ≠ 0}"
by (simp add: finite_subset in_keys_iff)
qed
thus ?thesis by (simp add: atomize_poly_def)
qed
lemma keys_proj_poly: "keys (proj_poly k p) = pp_of_term ` {x∈keys p. component_of_term x = k}"
proof
show "keys (proj_poly k p) ⊆ pp_of_term ` {x∈keys p. component_of_term x = k}"
proof
fix t
assume "t ∈ keys (proj_poly k p)"
hence "lookup (proj_poly k p) t ≠ 0" by (simp add: in_keys_iff)
hence "term_of_pair (t, k) ∈ keys p" by (simp add: in_keys_iff lookup_proj_poly)
hence "term_of_pair (t, k) ∈ {x∈keys p. component_of_term x = k}" by (simp add: term_simps)
hence "pp_of_term (term_of_pair (t, k)) ∈ pp_of_term ` {x∈keys p. component_of_term x = k}" by (rule imageI)
thus "t ∈ pp_of_term ` {x∈keys p. component_of_term x = k}" by (simp only: pp_of_term_of_pair)
qed
next
show "pp_of_term ` {x∈keys p. component_of_term x = k} ⊆ keys (proj_poly k p)"
proof
fix t
assume "t ∈ pp_of_term ` {x∈keys p. component_of_term x = k}"
then obtain x where "x ∈ {x∈keys p. component_of_term x = k}" and "t = pp_of_term x" ..
from this(1) have "x ∈ keys p" and "k = component_of_term x" by simp_all
from this(2) have "x = term_of_pair (t, k)" by (simp add: term_of_pair_pair ‹t = pp_of_term x›)
with ‹x ∈ keys p› have "lookup p (term_of_pair (t, k)) ≠ 0" by (simp add: in_keys_iff)
hence "lookup (proj_poly k p) t ≠ 0" by (simp add: lookup_proj_poly)
thus "t ∈ keys (proj_poly k p)" by (simp add: in_keys_iff)
qed
qed
lemma keys_vectorize_poly: "keys (vectorize_poly p) = component_of_term ` keys p"
proof
show "keys (vectorize_poly p) ⊆ component_of_term ` keys p"
proof
fix k
assume "k ∈ keys (vectorize_poly p)"
hence "lookup (vectorize_poly p) k ≠ 0" by (simp add: in_keys_iff)
hence "proj_poly k p ≠ 0" by (simp add: lookup_vectorize_poly)
then obtain t where "lookup (proj_poly k p) t ≠ 0" using aux by blast
hence "term_of_pair (t, k) ∈ keys p" by (simp add: lookup_proj_poly in_keys_iff)
hence "component_of_term (term_of_pair (t, k)) ∈ component_of_term ` keys p" by (rule imageI)
thus "k ∈ component_of_term ` keys p" by (simp only: component_of_term_of_pair)
qed
next
show "component_of_term ` keys p ⊆ keys (vectorize_poly p)"
proof
fix k
assume "k ∈ component_of_term ` keys p"
then obtain x where "x ∈ keys p" and "k = component_of_term x" ..
from this(2) have "term_of_pair (pp_of_term x, k) = x" by (simp add: term_of_pair_pair)
with ‹x ∈ keys p› have "lookup p (term_of_pair (pp_of_term x, k)) ≠ 0" by (simp add: in_keys_iff)
hence "lookup (proj_poly k p) (pp_of_term x) ≠ 0" by (simp add: lookup_proj_poly)
hence "proj_poly k p ≠ 0" by auto
hence "lookup (vectorize_poly p) k ≠ 0" by (simp add: lookup_vectorize_poly)
thus "k ∈ keys (vectorize_poly p)" by (simp add: in_keys_iff)
qed
qed
lemma keys_atomize_poly:
"keys (atomize_poly p) = (⋃k∈keys p. (λt. term_of_pair (t, k)) ` keys (lookup p k))" (is "?l = ?r")
proof
show "?l ⊆ ?r"
proof
fix v
assume "v ∈ ?l"
hence "lookup (atomize_poly p) v ≠ 0" by (simp add: in_keys_iff)
hence *: "pp_of_term v ∈ keys (lookup p (component_of_term v))" by (simp add: in_keys_iff lookup_atomize_poly)
hence "lookup p (component_of_term v) ≠ 0" by fastforce
hence "component_of_term v ∈ keys p" by (simp add: in_keys_iff)
thus "v ∈ ?r"
proof
from * have "term_of_pair (pp_of_term v, component_of_term v) ∈
(λt. term_of_pair (t, component_of_term v)) ` keys (lookup p (component_of_term v))"
by (rule imageI)
thus "v ∈ (λt. term_of_pair (t, component_of_term v)) ` keys (lookup p (component_of_term v))"
by (simp only: term_of_pair_pair)
qed
qed
next
show "?r ⊆ ?l"
proof
fix v
assume "v ∈ ?r"
then obtain k where "k ∈ keys p" and "v ∈ (λt. term_of_pair (t, k)) ` keys (lookup p k)" ..
from this(2) obtain t where "t ∈ keys (lookup p k)" and v: "v = term_of_pair (t, k)" ..
from this(1) have "lookup (atomize_poly p) v ≠ 0" by (simp add: v lookup_atomize_poly in_keys_iff term_simps)
thus "v ∈ ?l" by (simp add: in_keys_iff)
qed
qed
lemma proj_atomize_poly [term_simps]: "proj_poly k (atomize_poly p) = lookup p k"
by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_atomize_poly term_simps)
lemma vectorize_atomize_poly [term_simps]: "vectorize_poly (atomize_poly p) = p"
by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly term_simps)
lemma atomize_vectorize_poly [term_simps]: "atomize_poly (vectorize_poly p) = p"
by (rule poly_mapping_eqI, simp add: lookup_atomize_poly lookup_vectorize_poly lookup_proj_poly term_simps)
lemma proj_zero [term_simps]: "proj_poly k 0 = 0"
by (rule poly_mapping_eqI, simp add: lookup_proj_poly)
lemma proj_plus: "proj_poly k (p + q) = proj_poly k p + proj_poly k q"
by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_add)
lemma proj_uminus [term_simps]: "proj_poly k (- p) = - proj_poly k p"
by (rule poly_mapping_eqI, simp add: lookup_proj_poly)
lemma proj_minus: "proj_poly k (p - q) = proj_poly k p - proj_poly k q"
by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_minus)
lemma vectorize_zero [term_simps]: "vectorize_poly 0 = 0"
by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly term_simps)
lemma vectorize_plus: "vectorize_poly (p + q) = vectorize_poly p + vectorize_poly q"
by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly lookup_add proj_plus)
lemma vectorize_uminus [term_simps]: "vectorize_poly (- p) = - vectorize_poly p"
by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly term_simps)
lemma vectorize_minus: "vectorize_poly (p - q) = vectorize_poly p - vectorize_poly q"
by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly lookup_minus proj_minus)
lemma atomize_zero [term_simps]: "atomize_poly 0 = 0"
by (rule poly_mapping_eqI, simp add: lookup_atomize_poly)
lemma atomize_plus: "atomize_poly (p + q) = atomize_poly p + atomize_poly q"
by (rule poly_mapping_eqI, simp add: lookup_atomize_poly lookup_add)
lemma atomize_uminus [term_simps]: "atomize_poly (- p) = - atomize_poly p"
by (rule poly_mapping_eqI, simp add: lookup_atomize_poly)
lemma atomize_minus: "atomize_poly (p - q) = atomize_poly p - atomize_poly q"
by (rule poly_mapping_eqI, simp add: lookup_atomize_poly lookup_minus)
lemma proj_monomial:
"proj_poly k (monomial c v) = (monomial c (pp_of_term v) when component_of_term v = k)"
proof (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_single when_def term_simps, intro impI)
fix t
assume 1: "pp_of_term v = t" and 2: "component_of_term v = k"
assume "v ≠ term_of_pair (t, k)"
moreover have "v = term_of_pair (t, k)" by (simp add: 1[symmetric] 2[symmetric] term_simps)
ultimately show "c = 0" ..
qed
lemma vectorize_monomial:
"vectorize_poly (monomial c v) = monomial (monomial c (pp_of_term v)) (component_of_term v)"
by (rule poly_mapping_eqI, simp add: lookup_vectorize_poly proj_monomial lookup_single)
lemma atomize_monomial_monomial:
"atomize_poly (monomial (monomial c t) k) = monomial c (term_of_pair (t, k))"
proof -
define v where "v = term_of_pair (t, k)"
have t: "t = pp_of_term v" and k: "k = component_of_term v" by (simp_all add: v_def term_simps)
show ?thesis by (simp add: t k vectorize_monomial[symmetric] term_simps)
qed
lemma poly_mapping_eqI_proj:
assumes "⋀k. proj_poly k p = proj_poly k q"
shows "p = q"
proof (rule poly_mapping_eqI)
fix v::'t
have "proj_poly (component_of_term v) p = proj_poly (component_of_term v) q" by (rule assms)
hence "lookup (proj_poly (component_of_term v) p) (pp_of_term v) =
lookup (proj_poly (component_of_term v) q) (pp_of_term v)" by simp
thus "lookup p v = lookup q v" by (simp add: lookup_proj_poly term_simps)
qed
subsection ‹Scalar Multiplication by Monomials›
definition monom_mult :: "'b::semiring_0 ⇒ 'a::comm_powerprod ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b)"
where "monom_mult c t p = Abs_poly_mapping (λv. if t adds⇩p v then c * (lookup p (v ⊖ t)) else 0)"
lemma keys_monom_mult_aux:
"{v. (if t adds⇩p v then c * lookup p (v ⊖ t) else 0) ≠ 0} ⊆ (⊕) t ` keys p" (is "?l ⊆ ?r")
for c::"'b::semiring_0"
proof
fix v::'t
assume "v ∈ ?l"
hence "(if t adds⇩p v then c * lookup p (v ⊖ t) else 0) ≠ 0" by simp
hence "t adds⇩p v" and cp_not_zero: "c * lookup p (v ⊖ t) ≠ 0" by (simp_all split: if_split_asm)
show "v ∈ ?r"
proof
from adds_pp_sminus[OF ‹t adds⇩p v›] show "v = t ⊕ (v ⊖ t)" by simp
next
from mult_not_zero[OF cp_not_zero] show "v ⊖ t ∈ keys p"
by (simp add: in_keys_iff)
qed
qed
lemma lookup_monom_mult:
"lookup (monom_mult c t p) v = (if t adds⇩p v then c * lookup p (v ⊖ t) else 0)"
proof -
have "lookup (monom_mult c t p) = (λv. if t adds⇩p v then c * lookup p (v ⊖ t) else 0)"
unfolding monom_mult_def
proof (rule Abs_poly_mapping_inverse)
from finite_keys have "finite ((⊕) t ` keys p)" ..
with keys_monom_mult_aux have "finite {v. (if t adds⇩p v then c * lookup p (v ⊖ t) else 0) ≠ 0}"
by (rule finite_subset)
thus "(λv. if t adds⇩p v then c * lookup p (v ⊖ t) else 0) ∈ {f. finite {x. f x ≠ 0}}" by simp
qed
thus ?thesis by simp
qed
lemma lookup_monom_mult_plus:
"lookup (monom_mult c t p) (t ⊕ v) = (c::'b::semiring_0) * lookup p v"
by (simp add: lookup_monom_mult term_simps)
lemma monom_mult_assoc: "monom_mult c s (monom_mult d t p) = monom_mult (c * d) (s + t) p"
proof (rule poly_mapping_eqI, simp add: lookup_monom_mult sminus_plus ac_simps, intro conjI impI)
fix v
assume "s adds⇩p v" and "t adds⇩p v ⊖ s"
hence "s + t adds⇩p v" by (rule plus_adds_ppI_2)
moreover assume "¬ s + t adds⇩p v"
ultimately show "c * (d * lookup p (v ⊖ s ⊖ t)) = 0" by simp
next
fix v
assume "s + t adds⇩p v"
hence "s adds⇩p v" by (rule plus_adds_pp_left)
moreover assume "¬ s adds⇩p v"
ultimately show "c * (d * lookup p (v ⊖ (s + t))) = 0" by simp
next
fix v
assume "s + t adds⇩p v"
hence "t adds⇩p v ⊖ s" by (simp add: add.commute plus_adds_pp_0)
moreover assume "¬ t adds⇩p v ⊖ s"
ultimately show "c * (d * lookup p (v ⊖ (s + t))) = 0" by simp
qed
lemma monom_mult_uminus_left: "monom_mult (- c) t p = - monom_mult (c::'b::ring) t p"
by (rule poly_mapping_eqI, simp add: lookup_monom_mult)
lemma monom_mult_uminus_right: "monom_mult c t (- p) = - monom_mult (c::'b::ring) t p"
by (rule poly_mapping_eqI, simp add: lookup_monom_mult)
lemma uminus_monom_mult: "- p = monom_mult (-1::'b::comm_ring_1) 0 p"
by (rule poly_mapping_eqI, simp add: lookup_monom_mult term_simps)
lemma monom_mult_dist_left: "monom_mult (c + d) t p = (monom_mult c t p) + (monom_mult d t p)"
by (rule poly_mapping_eqI, simp add: lookup_monom_mult lookup_add algebra_simps)
lemma monom_mult_dist_left_minus:
"monom_mult (c - d) t p = (monom_mult c t p) - (monom_mult (d::'b::ring) t p)"
using monom_mult_dist_left[of c "-d" t p] monom_mult_uminus_left[of d t p] by simp
lemma monom_mult_dist_right:
"monom_mult c t (p + q) = (monom_mult c t p) + (monom_mult c t q)"
by (rule poly_mapping_eqI, simp add: lookup_monom_mult lookup_add algebra_simps)
lemma monom_mult_dist_right_minus:
"monom_mult c t (p - q) = (monom_mult c t p) - (monom_mult (c::'b::ring) t q)"
using monom_mult_dist_right[of c t p "-q"] monom_mult_uminus_right[of c t q] by simp
lemma monom_mult_zero_left [simp]: "monom_mult 0 t p = 0"
by (rule poly_mapping_eqI, simp add: lookup_monom_mult)
lemma monom_mult_zero_right [simp]: "monom_mult c t 0 = 0"
by (rule poly_mapping_eqI, simp add: lookup_monom_mult)
lemma monom_mult_one_left [simp]: "(monom_mult (1::'b::semiring_1) 0 p) = p"
by (rule poly_mapping_eqI, simp add: lookup_monom_mult term_simps)
lemma monom_mult_monomial:
"monom_mult c s (monomial d v) = monomial (c * (d::'b::semiring_0)) (s ⊕ v)"
by (rule poly_mapping_eqI, auto simp add: lookup_monom_mult lookup_single adds_pp_alt when_def term_simps, metis)
lemma monom_mult_eq_zero_iff: "(monom_mult c t p = 0) ⟷ ((c::'b::semiring_no_zero_divisors) = 0 ∨ p = 0)"
proof
assume eq: "monom_mult c t p = 0"
show "c = 0 ∨ p = 0"
proof (rule ccontr, simp)
assume "c ≠ 0 ∧ p ≠ 0"
hence "c ≠ 0" and "p ≠ 0" by simp_all
from lookup_zero poly_mapping_eq_iff[of p 0] ‹p ≠ 0› obtain v where "lookup p v ≠ 0" by fastforce
from eq lookup_zero have "lookup (monom_mult c t p) (t ⊕ v) = 0" by simp
hence "c * lookup p v = 0" by (simp only: lookup_monom_mult_plus)
with ‹c ≠ 0› ‹lookup p v ≠ 0› show False by auto
qed
next
assume "c = 0 ∨ p = 0"
with monom_mult_zero_left[of t p] monom_mult_zero_right[of c t] show "monom_mult c t p = 0" by auto
qed
lemma lookup_monom_mult_zero: "lookup (monom_mult c 0 p) t = c * lookup p t"
proof -
have "lookup (monom_mult c 0 p) t = lookup (monom_mult c 0 p) (0 ⊕ t)" by (simp add: term_simps)
also have "... = c * lookup p t" by (rule lookup_monom_mult_plus)
finally show ?thesis .
qed
lemma monom_mult_inj_1:
assumes "monom_mult c1 t p = monom_mult c2 t p"
and "(p::(_ ⇒⇩0 'b::semiring_no_zero_divisors_cancel)) ≠ 0"
shows "c1 = c2"
proof -
from assms(2) have "keys p ≠ {}" using poly_mapping_eq_zeroI by blast
then obtain v where "v ∈ keys p" by blast
hence *: "lookup p v ≠ 0" by (simp add: in_keys_iff)
from assms(1) have "lookup (monom_mult c1 t p) (t ⊕ v) = lookup (monom_mult c2 t p) (t ⊕ v)"
by simp
hence "c1 * lookup p v = c2 * lookup p v" by (simp only: lookup_monom_mult_plus)
with * show ?thesis by auto
qed
text ‹Multiplication by a monomial is injective in the second argument (the power-product) only in
context @{locale ordered_powerprod}; see lemma ‹monom_mult_inj_2› below.›
lemma monom_mult_inj_3:
assumes "monom_mult c t p1 = monom_mult c t (p2::(_ ⇒⇩0 'b::semiring_no_zero_divisors_cancel))"
and "c ≠ 0"
shows "p1 = p2"
proof (rule poly_mapping_eqI)
fix v
from assms(1) have "lookup (monom_mult c t p1) (t ⊕ v) = lookup (monom_mult c t p2) (t ⊕ v)"
by simp
hence "c * lookup p1 v = c * lookup p2 v" by (simp only: lookup_monom_mult_plus)
with assms(2) show "lookup p1 v = lookup p2 v" by simp
qed
lemma keys_monom_multI:
assumes "v ∈ keys p" and "c ≠ (0::'b::semiring_no_zero_divisors)"
shows "t ⊕ v ∈ keys (monom_mult c t p)"
using assms unfolding in_keys_iff lookup_monom_mult_plus by simp
lemma keys_monom_mult_subset: "keys (monom_mult c t p) ⊆ ((⊕) t) ` (keys p)"
proof -
have "keys (monom_mult c t p) ⊆ {v. (if t adds⇩p v then c * lookup p (v ⊖ t) else 0) ≠ 0}" (is "_ ⊆ ?A")
proof
fix v
assume "v ∈ keys (monom_mult c t p)"
hence "lookup (monom_mult c t p) v ≠ 0" by (simp add: in_keys_iff)
thus "v ∈ ?A" unfolding lookup_monom_mult by simp
qed
also note keys_monom_mult_aux
finally show ?thesis .
qed
lemma keys_monom_multE:
assumes "v ∈ keys (monom_mult c t p)"
obtains u where "u ∈ keys p" and "v = t ⊕ u"
proof -
note assms
also have "keys (monom_mult c t p) ⊆ ((⊕) t) ` (keys p)" by (fact keys_monom_mult_subset)
finally have "v ∈ ((⊕) t) ` (keys p)" .
then obtain u where "u ∈ keys p" and "v = t ⊕ u" ..
thus ?thesis ..
qed
lemma keys_monom_mult:
assumes "c ≠ (0::'b::semiring_no_zero_divisors)"
shows "keys (monom_mult c t p) = ((⊕) t) ` (keys p)"
proof (rule, fact keys_monom_mult_subset, rule)
fix v
assume "v ∈ (⊕) t ` keys p"
then obtain u where "u ∈ keys p" and v: "v = t ⊕ u" ..
from ‹u ∈ keys p› assms show "v ∈ keys (monom_mult c t p)" unfolding v by (rule keys_monom_multI)
qed
lemma monom_mult_when: "monom_mult c t (p when P) = ((monom_mult c t p) when P)"
by (cases P, simp_all)
lemma when_monom_mult: "monom_mult (c when P) t p = ((monom_mult c t p) when P)"
by (cases P, simp_all)
lemma monomial_power: "(monomial c t) ^ n = monomial (c ^ n) (∑i=0..<n. t)"
by (induct n, simp_all add: mult_single monom_mult_monomial add.commute)
subsection ‹Component-wise Lifting›
text ‹Component-wise lifting of functions on @{typ "'a ⇒⇩0 'b"} to functions on @{typ "'t ⇒⇩0 'b"}.›
definition lift_poly_fun_2 :: "(('a ⇒⇩0 'b) ⇒ ('a ⇒⇩0 'b) ⇒ ('a ⇒⇩0 'b)) ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::zero)"
where "lift_poly_fun_2 f p q = atomize_poly (mapp_2 (λ_. f) (vectorize_poly p) (vectorize_poly q))"
definition lift_poly_fun :: "(('a ⇒⇩0 'b) ⇒ ('a ⇒⇩0 'b)) ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::zero)"
where "lift_poly_fun f p = lift_poly_fun_2 (λ_. f) 0 p"
lemma lookup_lift_poly_fun_2:
"lookup (lift_poly_fun_2 f p q) v =
(lookup (f (proj_poly (component_of_term v) p) (proj_poly (component_of_term v) q)) (pp_of_term v)
when component_of_term v ∈ keys (vectorize_poly p) ∪ keys (vectorize_poly q))"
by (simp add: lift_poly_fun_2_def lookup_atomize_poly lookup_mapp_2 lookup_vectorize_poly
when_distrib[of _ "λq. lookup q (pp_of_term v)", OF lookup_zero])
lemma lookup_lift_poly_fun:
"lookup (lift_poly_fun f p) v =
(lookup (f (proj_poly (component_of_term v) p)) (pp_of_term v) when component_of_term v ∈ keys (vectorize_poly p))"
by (simp add: lift_poly_fun_def lookup_lift_poly_fun_2 term_simps)
lemma lookup_lift_poly_fun_2_homogenous:
assumes "f 0 0 = 0"
shows "lookup (lift_poly_fun_2 f p q) v =
lookup (f (proj_poly (component_of_term v) p) (proj_poly (component_of_term v) q)) (pp_of_term v)"
by (simp add: lookup_lift_poly_fun_2 when_def in_keys_iff lookup_vectorize_poly assms)
lemma proj_lift_poly_fun_2_homogenous:
assumes "f 0 0 = 0"
shows "proj_poly k (lift_poly_fun_2 f p q) = f (proj_poly k p) (proj_poly k q)"
by (rule poly_mapping_eqI,
simp add: lookup_proj_poly lookup_lift_poly_fun_2_homogenous[of f, OF assms] term_simps)
lemma lookup_lift_poly_fun_homogenous:
assumes "f 0 = 0"
shows "lookup (lift_poly_fun f p) v = lookup (f (proj_poly (component_of_term v) p)) (pp_of_term v)"
by (simp add: lookup_lift_poly_fun when_def in_keys_iff lookup_vectorize_poly assms)
lemma proj_lift_poly_fun_homogenous:
assumes "f 0 = 0"
shows "proj_poly k (lift_poly_fun f p) = f (proj_poly k p)"
by (rule poly_mapping_eqI,
simp add: lookup_proj_poly lookup_lift_poly_fun_homogenous[of f, OF assms] term_simps)
subsection ‹Component-wise Multiplication›
definition mult_vec :: "('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::semiring_0)" (infixl "**" 75)
where "mult_vec = lift_poly_fun_2 (*)"
lemma lookup_mult_vec:
"lookup (p ** q) v = lookup ((proj_poly (component_of_term v) p) * (proj_poly (component_of_term v) q)) (pp_of_term v)"
unfolding mult_vec_def by (rule lookup_lift_poly_fun_2_homogenous, simp)
lemma proj_mult_vec [term_simps]: "proj_poly k (p ** q) = (proj_poly k p) * (proj_poly k q)"
unfolding mult_vec_def by (rule proj_lift_poly_fun_2_homogenous, simp)
lemma mult_vec_zero_left: "0 ** p = 0"
by (rule poly_mapping_eqI_proj, simp add: term_simps)
lemma mult_vec_zero_right: "p ** 0 = 0"
by (rule poly_mapping_eqI_proj, simp add: term_simps)
lemma mult_vec_assoc: "(p ** q) ** r = p ** (q ** r)"
by (rule poly_mapping_eqI_proj, simp add: ac_simps term_simps)
lemma mult_vec_distrib_right: "(p + q) ** r = p ** r + q ** r"
by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus term_simps)
lemma mult_vec_distrib_left: "r ** (p + q) = r ** p + r ** q"
by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus term_simps)
lemma mult_vec_minus_mult_left: "(- p) ** q = - (p ** q)"
by (rule sym, rule minus_unique, simp add: mult_vec_distrib_right[symmetric] mult_vec_zero_left)
lemma mult_vec_minus_mult_right: "p ** (- q) = - (p ** q)"
by (rule sym, rule minus_unique, simp add: mult_vec_distrib_left [symmetric] mult_vec_zero_right)
lemma minus_mult_vec_minus: "(- p) ** (- q) = p ** q"
by (simp add: mult_vec_minus_mult_left mult_vec_minus_mult_right)
lemma minus_mult_vec_commute: "(- p) ** q = p ** (- q)"
by (simp add: mult_vec_minus_mult_left mult_vec_minus_mult_right)
lemma mult_vec_right_diff_distrib: "r ** (p - q) = r ** p - r ** q"
for r::"_ ⇒⇩0 'b::ring"
using mult_vec_distrib_left [of r p "- q"] by (simp add: mult_vec_minus_mult_right)
lemma mult_vec_left_diff_distrib: "(p - q) ** r = p ** r - q ** r"
for p::"_ ⇒⇩0 'b::ring"
using mult_vec_distrib_right [of p "- q" r] by (simp add: mult_vec_minus_mult_left)
lemma mult_vec_commute: "p ** q = q ** p" for p::"_ ⇒⇩0 'b::comm_semiring_0"
by (rule poly_mapping_eqI_proj, simp add: term_simps ac_simps)
lemma mult_vec_left_commute: "p ** (q ** r) = q ** (p ** r)"
for p::"_ ⇒⇩0 'b::comm_semiring_0"
by (rule poly_mapping_eqI_proj, simp add: term_simps ac_simps)
lemma mult_vec_monomial_monomial:
"(monomial c u) ** (monomial d v) =
(monomial (c * d) (term_of_pair (pp_of_term u + pp_of_term v, component_of_term u)) when
component_of_term u = component_of_term v)"
by (rule poly_mapping_eqI_proj, simp add: proj_monomial mult_single when_def term_simps)
lemma mult_vec_rec_left: "p ** q = monomial (lookup p v) v ** q + (except p {v}) ** q"
proof -
from plus_except[of p v] have "p ** q = (monomial (lookup p v) v + except p {v}) ** q" by simp
also have "... = monomial (lookup p v) v ** q + except p {v} ** q"
by (simp only: mult_vec_distrib_right)
finally show ?thesis .
qed
lemma mult_vec_rec_right: "p ** q = p ** monomial (lookup q v) v + p ** except q {v}"
proof -
have "p ** monomial (lookup q v) v + p ** except q {v} = p ** (monomial (lookup q v) v + except q {v})"
by (simp only: mult_vec_distrib_left)
also have "... = p ** q" by (simp only: plus_except[of q v, symmetric])
finally show ?thesis by simp
qed
lemma in_keys_mult_vecE:
assumes "w ∈ keys (p ** q)"
obtains u v where "u ∈ keys p" and "v ∈ keys q" and "component_of_term u = component_of_term v"
and "w = term_of_pair (pp_of_term u + pp_of_term v, component_of_term u)"
proof -
from assms have "0 ≠ lookup (p ** q) w" by (simp add: in_keys_iff)
also have "lookup (p ** q) w =
lookup ((proj_poly (component_of_term w) p) * (proj_poly (component_of_term w) q)) (pp_of_term w)"
by (fact lookup_mult_vec)
finally have "pp_of_term w ∈ keys ((proj_poly (component_of_term w) p) * (proj_poly (component_of_term w) q))"
by (simp add: in_keys_iff)
from this keys_mult
have "pp_of_term w ∈ {t + s |t s. t ∈ keys (proj_poly (component_of_term w) p) ∧
s ∈ keys (proj_poly (component_of_term w) q)}" ..
then obtain t s where 1: "t ∈ keys (proj_poly (component_of_term w) p)"
and 2: "s ∈ keys (proj_poly (component_of_term w) q)"
and eq: "pp_of_term w = t + s" by fastforce
let ?u = "term_of_pair (t, component_of_term w)"
let ?v = "term_of_pair (s, component_of_term w)"
from 1 have "?u ∈ keys p" by (simp only: in_keys_iff lookup_proj_poly not_False_eq_True)
moreover from 2 have "?v ∈ keys q" by (simp only: in_keys_iff lookup_proj_poly not_False_eq_True)
moreover have "component_of_term ?u = component_of_term ?v" by (simp add: term_simps)
moreover have "w = term_of_pair (pp_of_term ?u + pp_of_term ?v, component_of_term ?u)"
by (simp add: eq[symmetric] term_simps)
ultimately show ?thesis ..
qed
lemma lookup_mult_vec_monomial_left:
"lookup (monomial c v ** p) u =
(c * lookup p (term_of_pair (pp_of_term u - pp_of_term v, component_of_term u)) when v adds⇩t u)"
proof -
have eq1: "lookup ((monomial c (pp_of_term v) when component_of_term v = component_of_term u) * proj_poly (component_of_term u) p)
(pp_of_term u) =
(lookup ((monomial c (pp_of_term v)) * proj_poly (component_of_term u) p) (pp_of_term u) when
component_of_term v = component_of_term u)"
by (rule when_distrib, simp)
show ?thesis
by (simp add: lookup_mult_vec proj_monomial eq1 lookup_times_monomial_left when_when
adds_term_def lookup_proj_poly conj_commute)
qed
lemma lookup_mult_vec_monomial_right:
"lookup (p ** monomial c v) u =
(lookup p (term_of_pair (pp_of_term u - pp_of_term v, component_of_term u)) * c when v adds⇩t u)"
proof -
have eq1: "lookup (proj_poly (component_of_term u) p * (monomial c (pp_of_term v) when component_of_term v = component_of_term u))
(pp_of_term u) =
(lookup (proj_poly (component_of_term u) p * (monomial c (pp_of_term v))) (pp_of_term u) when
component_of_term v = component_of_term u)"
by (rule when_distrib, simp)
show ?thesis
by (simp add: lookup_mult_vec proj_monomial eq1 lookup_times_monomial_right when_when
adds_term_def lookup_proj_poly conj_commute)
qed
subsection ‹Scalar Multiplication›
definition mult_scalar :: "('a ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::semiring_0)" (infixl "⊙" 75)
where "mult_scalar p = lift_poly_fun ((*) p)"
lemma lookup_mult_scalar:
"lookup (p ⊙ q) v = lookup (p * (proj_poly (component_of_term v) q)) (pp_of_term v)"
unfolding mult_scalar_def by (rule lookup_lift_poly_fun_homogenous, simp)
lemma lookup_mult_scalar_explicit:
"lookup (p ⊙ q) u = (∑t∈keys p. lookup p t * (∑v∈keys q. lookup q v when u = t ⊕ v))"
proof -
let ?f = "λt s. lookup (proj_poly (component_of_term u) q) s when pp_of_term u = t + s"
note lookup_mult_scalar
also have "lookup (p * proj_poly (component_of_term u) q) (pp_of_term u) =
(∑t. lookup p t * (Sum_any (?f t)))"
by (fact lookup_mult)
also from finite_keys have "… = (∑t∈keys p. lookup p t * (Sum_any (?f t)))"
by (rule Sum_any.expand_superset) (auto simp: in_keys_iff dest: mult_not_zero)
also from refl have "… = (∑t∈keys p. lookup p t * (∑v∈keys q. lookup q v when u = t ⊕ v))"
proof (rule sum.cong)
fix t
assume "t ∈ keys p"
from finite_keys have "Sum_any (?f t) = (∑s∈keys (proj_poly (component_of_term u) q). ?f t s)"
by (rule Sum_any.expand_superset) (auto simp: in_keys_iff)
also have "… = (∑v∈{x ∈ keys q. component_of_term x = component_of_term u}. ?f t (pp_of_term v))"
unfolding keys_proj_poly
proof (intro sum.reindex[simplified o_def] inj_onI)
fix v1 v2
assume "v1 ∈ {x ∈ keys q. component_of_term x = component_of_term u}"
and "v2 ∈ {x ∈ keys q. component_of_term x = component_of_term u}"
hence "component_of_term v1 = component_of_term v2" by simp
moreover assume "pp_of_term v1 = pp_of_term v2"
ultimately show "v1 = v2" by (metis term_of_pair_pair)
qed
also from finite_keys have "… = (∑v∈keys q. lookup q v when u = t ⊕ v)"
proof (intro sum.mono_neutral_cong_left ballI)
fix v
assume "v ∈ keys q - {x ∈ keys q. component_of_term x = component_of_term u}"
hence "u ≠ t ⊕ v" by (auto simp: component_of_term_splus)
thus "(lookup q v when u = t ⊕ v) = 0" by simp
next
fix v
assume "v ∈ {x ∈ keys q. component_of_term x = component_of_term u}"
hence eq[symmetric]: "component_of_term v = component_of_term u" by simp
have "u = t ⊕ v ⟷ pp_of_term u = t + pp_of_term v"
proof
assume "pp_of_term u = t + pp_of_term v"
hence "pp_of_term u = pp_of_term (t ⊕ v)" by (simp only: pp_of_term_splus)
moreover have "component_of_term u = component_of_term (t ⊕ v)"
by (simp only: eq component_of_term_splus)
ultimately show "u = t ⊕ v" by (metis term_of_pair_pair)
qed (simp add: pp_of_term_splus)
thus "?f t (pp_of_term v) = (lookup q v when u = t ⊕ v)"
by (simp add: lookup_proj_poly eq term_of_pair_pair)
qed auto
finally show "lookup p t * (Sum_any (?f t)) = lookup p t * (∑v∈keys q. lookup q v when u = t ⊕ v)"
by (simp only:)
qed
finally show ?thesis .
qed
lemma proj_mult_scalar [term_simps]: "proj_poly k (p ⊙ q) = p * (proj_poly k q)"
unfolding mult_scalar_def by (rule proj_lift_poly_fun_homogenous, simp)
lemma mult_scalar_zero_left [simp]: "0 ⊙ p = 0"
by (rule poly_mapping_eqI_proj, simp add: term_simps)
lemma mult_scalar_zero_right [simp]: "p ⊙ 0 = 0"
by (rule poly_mapping_eqI_proj, simp add: term_simps)
lemma mult_scalar_one [simp]: "(1::_ ⇒⇩0 'b::semiring_1) ⊙ p = p"
by (rule poly_mapping_eqI_proj, simp add: term_simps)
lemma mult_scalar_assoc [ac_simps]: "(p * q) ⊙ r = p ⊙ (q ⊙ r)"
by (rule poly_mapping_eqI_proj, simp add: ac_simps term_simps)
lemma mult_scalar_distrib_right [algebra_simps]: "(p + q) ⊙ r = p ⊙ r + q ⊙ r"
by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus term_simps)
lemma mult_scalar_distrib_left [algebra_simps]: "r ⊙ (p + q) = r ⊙ p + r ⊙ q"
by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus term_simps)
lemma mult_scalar_minus_mult_left [simp]: "(- p) ⊙ q = - (p ⊙ q)"
by (rule sym, rule minus_unique, simp add: mult_scalar_distrib_right[symmetric])
lemma mult_scalar_minus_mult_right [simp]: "p ⊙ (- q) = - (p ⊙ q)"
by (rule sym, rule minus_unique, simp add: mult_scalar_distrib_left [symmetric])
lemma minus_mult_scalar_minus [simp]: "(- p) ⊙ (- q) = p ⊙ q"
by simp
lemma minus_mult_scalar_commute: "(- p) ⊙ q = p ⊙ (- q)"
by simp
lemma mult_scalar_right_diff_distrib [algebra_simps]: "r ⊙ (p - q) = r ⊙ p - r ⊙ q"
for r::"_ ⇒⇩0 'b::ring"
using mult_scalar_distrib_left [of r p "- q"] by simp
lemma mult_scalar_left_diff_distrib [algebra_simps]: "(p - q) ⊙ r = p ⊙ r - q ⊙ r"
for p::"_ ⇒⇩0 'b::ring"
using mult_scalar_distrib_right [of p "- q" r] by simp
lemma sum_mult_scalar_distrib_left: "r ⊙ (sum f A) = (∑a∈A. r ⊙ f a)"
by (induct A rule: infinite_finite_induct, simp_all add: algebra_simps)
lemma sum_mult_scalar_distrib_right: "(sum f A) ⊙ v = (∑a∈A. f a ⊙ v)"
by (induct A rule: infinite_finite_induct, simp_all add: algebra_simps)
lemma mult_scalar_monomial_monomial: "(monomial c t) ⊙ (monomial d v) = monomial (c * d) (t ⊕ v)"
by (rule poly_mapping_eqI_proj, simp add: proj_monomial mult_single when_def term_simps)
lemma mult_scalar_monomial: "(monomial c t) ⊙ p = monom_mult c t p"
by (rule poly_mapping_eqI_proj, rule poly_mapping_eqI,
auto simp add: lookup_times_monomial_left lookup_proj_poly lookup_monom_mult when_def
adds_pp_def sminus_def term_simps)
lemma mult_scalar_rec_left: "p ⊙ q = monom_mult (lookup p t) t q + (except p {t}) ⊙ q"
proof -
from plus_except[of p t] have "p ⊙ q = (monomial (lookup p t) t + except p {t}) ⊙ q" by simp
also have "... = monomial (lookup p t) t ⊙ q + except p {t} ⊙ q" by (simp only: algebra_simps)
finally show ?thesis by (simp only: mult_scalar_monomial)
qed
lemma mult_scalar_rec_right: "p ⊙ q = p ⊙ monomial (lookup q v) v + p ⊙ except q {v}"
proof -
have "p ⊙ monomial (lookup q v) v + p ⊙ except q {v} = p ⊙ (monomial (lookup q v) v + except q {v})"
by (simp only: mult_scalar_distrib_left)
also have "... = p ⊙ q" by (simp only: plus_except[of q v, symmetric])
finally show ?thesis by simp
qed
lemma in_keys_mult_scalarE:
assumes "v ∈ keys (p ⊙ q)"
obtains t u where "t ∈ keys p" and "u ∈ keys q" and "v = t ⊕ u"
proof -
from assms have "0 ≠ lookup (p ⊙ q) v" by (simp add: in_keys_iff)
also have "lookup (p ⊙ q) v = lookup (p * (proj_poly (component_of_term v) q)) (pp_of_term v)"
by (fact lookup_mult_scalar)
finally have "pp_of_term v ∈ keys (p * proj_poly (component_of_term v) q)" by (simp add: in_keys_iff)
from this keys_mult have "pp_of_term v ∈ {t + s |t s. t ∈ keys p ∧ s ∈ keys (proj_poly (component_of_term v) q)}" ..
then obtain t s where "t ∈ keys p" and *: "s ∈ keys (proj_poly (component_of_term v) q)"
and eq: "pp_of_term v = t + s" by fastforce
note this(1)
moreover from * have "term_of_pair (s, component_of_term v) ∈ keys q"
by (simp only: in_keys_iff lookup_proj_poly not_False_eq_True)
moreover have "v = t ⊕ term_of_pair (s, component_of_term v)"
by (simp add: splus_def eq[symmetric] term_simps)
ultimately show ?thesis ..
qed
lemma lookup_mult_scalar_monomial_right:
"lookup (p ⊙ monomial c v) u = (lookup p (pp_of_term u - pp_of_term v) * c when v adds⇩t u)"
proof -
have eq1: "lookup (p * (monomial c (pp_of_term v) when component_of_term v = component_of_term u)) (pp_of_term u) =
(lookup (p * (monomial c (pp_of_term v))) (pp_of_term u) when component_of_term v = component_of_term u)"
by (rule when_distrib, simp)
show ?thesis
by (simp add: lookup_mult_scalar eq1 proj_monomial lookup_times_monomial_right when_when
adds_term_def lookup_proj_poly conj_commute)
qed
lemma lookup_mult_scalar_monomial_right_plus: "lookup (p ⊙ monomial c v) (t ⊕ v) = lookup p t * c"
by (simp add: lookup_mult_scalar_monomial_right term_simps)
lemma keys_mult_scalar_monomial_right_subset: "keys (p ⊙ monomial c v) ⊆ (λt. t ⊕ v) ` keys p"
proof
fix u
assume "u ∈ keys (p ⊙ monomial c v)"
then obtain t w where "t ∈ keys p" and "w ∈ keys (monomial c v)" and "u = t ⊕ w"
by (rule in_keys_mult_scalarE)
from this(2) have "w = v" by (metis empty_iff insert_iff keys_single)
from ‹t ∈ keys p› show "u ∈ (λt. t ⊕ v) ` keys p" unfolding ‹u = t ⊕ w› ‹w = v› by fastforce
qed
lemma keys_mult_scalar_monomial_right:
assumes "c ≠ (0::'b::semiring_no_zero_divisors)"
shows "keys (p ⊙ monomial c v) = (λt. t ⊕ v) ` keys p"
proof
show "(λt. t ⊕ v) ` keys p ⊆ keys (p ⊙ monomial c v)"
proof
fix u
assume "u ∈ (λt. t ⊕ v) ` keys p"
then obtain t where "t ∈ keys p" and "u = t ⊕ v" ..
have "lookup (p ⊙ monomial c v) (t ⊕ v) = lookup p t * c"
by (fact lookup_mult_scalar_monomial_right_plus)
also from ‹t ∈ keys p› assms have "... ≠ 0" by (simp add: in_keys_iff)
finally show "u ∈ keys (p ⊙ monomial c v)" by (simp add: in_keys_iff ‹u = t ⊕ v›)
qed
qed (fact keys_mult_scalar_monomial_right_subset)
end
subsection ‹Sums and Products›
lemma sum_poly_mapping_eq_zeroI:
assumes "p ` A ⊆ {0}"
shows "sum p A = (0::(_ ⇒⇩0 'b::comm_monoid_add))"
proof (rule ccontr)
assume "sum p A ≠ 0"
then obtain a where "a ∈ A" and "p a ≠ 0"
by (rule comm_monoid_add_class.sum.not_neutral_contains_not_neutral)
with assms show False by auto
qed
lemma lookup_sum_list: "lookup (sum_list ps) a = sum_list (map (λp. lookup p a) ps)"
proof (induct ps)
case Nil
show ?case by simp
next
case (Cons p ps)
thus ?case by (simp add: lookup_add)
qed
text ‹Legacy:›
lemmas keys_sum_subset = Poly_Mapping.keys_sum
lemma keys_sum_list_subset: "keys (sum_list ps) ⊆ Keys (set ps)"
proof (induct ps)
case Nil
show ?case by simp
next
case (Cons p ps)
have "keys (sum_list (p # ps)) = keys (p + sum_list ps)" by simp
also have "… ⊆ keys p ∪ keys (sum_list ps)" by (fact Poly_Mapping.keys_add)
also from Cons have "… ⊆ keys p ∪ Keys (set ps)" by blast
also have "… = Keys (set (p # ps))" by (simp add: Keys_insert)
finally show ?case .
qed
lemma keys_sum:
assumes "finite A" and "⋀a1 a2. a1 ∈ A ⟹ a2 ∈ A ⟹ a1 ≠ a2 ⟹ keys (f a1) ∩ keys (f a2) = {}"
shows "keys (sum f A) = (⋃a∈A. keys (f a))"
using assms
proof (induct A)
case empty
show ?case by simp
next
case (insert a A)
have IH: "keys (sum f A) = (⋃i∈A. keys (f i))" by (rule insert(3), rule insert.prems, simp_all)
have "keys (sum f (insert a A)) = keys (f a) ∪ keys (sum f A)"
proof (simp only: comm_monoid_add_class.sum.insert[OF insert(1) insert(2)], rule keys_add[symmetric])
have "keys (f a) ∩ keys (sum f A) = (⋃i∈A. keys (f a) ∩ keys (f i))"
by (simp only: IH Int_UN_distrib)
also have "... = {}"
proof -
have "i ∈ A ⟹ keys (f a) ∩ keys (f i) = {}" for i
proof (rule insert.prems)
assume "i ∈ A"
with insert(2) show "a ≠ i" by blast
qed simp_all
thus ?thesis by simp
qed
finally show "keys (f a) ∩ keys (sum f A) = {}" .
qed
also have "... = (⋃a∈insert a A. keys (f a))" by (simp add: IH)
finally show ?case .
qed
lemma poly_mapping_sum_monomials: "(∑a∈keys p. monomial (lookup p a) a) = p"
proof (induct p rule: poly_mapping_plus_induct)
case 1
show ?case by simp
next
case step: (2 p c t)
from step(2) have "lookup p t = 0" by (simp add: in_keys_iff)
have *: "keys (monomial c t + p) = insert t (keys p)"
proof -
from step(1) have a: "keys (monomial c t) = {t}" by simp
with step(2) have "keys (monomial c t) ∩ keys p = {}" by simp
hence "keys (monomial c t + p) = {t} ∪ keys p" by (simp only: a keys_plus_eqI)
thus ?thesis by simp
qed
have **: "(∑ta∈keys p. monomial ((c when t = ta) + lookup p ta) ta) = (∑ta∈keys p. monomial (lookup p ta) ta)"
proof (rule comm_monoid_add_class.sum.cong, rule refl)
fix s
assume "s ∈ keys p"
with step(2) have "t ≠ s" by auto
thus "monomial ((c when t = s) + lookup p s) s = monomial (lookup p s) s" by simp
qed
show ?case by (simp only: * comm_monoid_add_class.sum.insert[OF finite_keys step(2)],
simp add: lookup_add lookup_single ‹lookup p t = 0› ** step(3))
qed
lemma monomial_sum: "monomial (sum f C) a = (∑c∈C. monomial (f c) a)"
by (rule fun_sum_commute, simp_all add: single_add)
lemma monomial_Sum_any:
assumes "finite {c. f c ≠ 0}"
shows "monomial (Sum_any f) a = (∑c. monomial (f c) a)"
proof -
have "{c. monomial (f c) a ≠ 0} ⊆ {c. f c ≠ 0}" by (rule, auto)
with assms show ?thesis
by (simp add: Groups_Big_Fun.comm_monoid_add_class.Sum_any.expand_superset monomial_sum)
qed
context term_powerprod
begin
lemma proj_sum: "proj_poly k (sum f A) = (∑a∈A. proj_poly k (f a))"
using proj_zero proj_plus by (rule fun_sum_commute)
lemma proj_sum_list: "proj_poly k (sum_list xs) = sum_list (map (proj_poly k) xs)"
using proj_zero proj_plus by (rule fun_sum_list_commute)
lemma mult_scalar_sum_monomials: "q ⊙ p = (∑t∈keys q. monom_mult (lookup q t) t p)"
by (rule poly_mapping_eqI_proj, simp add: proj_sum mult_scalar_monomial[symmetric]
sum_distrib_right[symmetric] poly_mapping_sum_monomials term_simps)
lemma fun_mult_scalar_commute:
assumes "f 0 = 0" and "⋀x y. f (x + y) = f x + f y"
and "⋀c t. f (monom_mult c t p) = monom_mult c t (f p)"
shows "f (q ⊙ p) = q ⊙ (f p)"
by (simp add: mult_scalar_sum_monomials assms(3)[symmetric], rule fun_sum_commute, fact+)
lemma fun_mult_scalar_commute_canc:
assumes "⋀x y. f (x + y) = f x + f y" and "⋀c t. f (monom_mult c t p) = monom_mult c t (f p)"
shows "f (q ⊙ p) = q ⊙ (f (p::'t ⇒⇩0 'b::{semiring_0,cancel_comm_monoid_add}))"
by (simp add: mult_scalar_sum_monomials assms(2)[symmetric], rule fun_sum_commute_canc, fact)
lemma monom_mult_sum_left: "monom_mult (sum f C) t p = (∑c∈C. monom_mult (f c) t p)"
by (rule fun_sum_commute, simp_all add: monom_mult_dist_left)
lemma monom_mult_sum_right: "monom_mult c t (sum f P) = (∑p∈P. monom_mult c t (f p))"
by (rule fun_sum_commute, simp_all add: monom_mult_dist_right)
lemma monom_mult_Sum_any_left:
assumes "finite {c. f c ≠ 0}"
shows "monom_mult (Sum_any f) t p = (∑c. monom_mult (f c) t p)"
proof -
have "{c. monom_mult (f c) t p ≠ 0} ⊆ {c. f c ≠ 0}" by (rule, auto)
with assms show ?thesis
by (simp add: Groups_Big_Fun.comm_monoid_add_class.Sum_any.expand_superset monom_mult_sum_left)
qed
lemma monom_mult_Sum_any_right:
assumes "finite {p. f p ≠ 0}"
shows "monom_mult c t (Sum_any f) = (∑p. monom_mult c t (f p))"
proof -
have "{p. monom_mult c t (f p) ≠ 0} ⊆ {p. f p ≠ 0}" by (rule, auto)
with assms show ?thesis
by (simp add: Groups_Big_Fun.comm_monoid_add_class.Sum_any.expand_superset monom_mult_sum_right)
qed
lemma monomial_prod_sum: "monomial (prod c I) (sum a I) = (∏i∈I. monomial (c i) (a i))"
proof (cases "finite I")
case True
thus ?thesis
proof (induct I)
case empty
show ?case by simp
next
case (insert i I)
show ?case
by (simp only: comm_monoid_add_class.sum.insert[OF insert(1) insert(2)]
comm_monoid_mult_class.prod.insert[OF insert(1) insert(2)] insert(3) mult_single[symmetric])
qed
next
case False
thus ?thesis by simp
qed
subsection ‹Submodules›
sublocale pmdl: module mult_scalar
apply standard
subgoal by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus)
subgoal by (rule poly_mapping_eqI_proj, simp add: algebra_simps proj_plus)
subgoal by (rule poly_mapping_eqI_proj, simp add: ac_simps)
subgoal by (rule poly_mapping_eqI_proj, simp)
done
lemmas [simp del] = pmdl.scale_one pmdl.scale_zero_left pmdl.scale_zero_right pmdl.scale_scale
pmdl.scale_minus_left pmdl.scale_minus_right pmdl.span_eq_iff
lemmas [algebra_simps del] = pmdl.scale_left_distrib pmdl.scale_right_distrib
pmdl.scale_left_diff_distrib pmdl.scale_right_diff_distrib
abbreviation "pmdl ≡ pmdl.span"
lemma pmdl_closed_monom_mult:
assumes "p ∈ pmdl B"
shows "monom_mult c t p ∈ pmdl B"
unfolding mult_scalar_monomial[symmetric] using assms by (rule pmdl.span_scale)
lemma monom_mult_in_pmdl: "b ∈ B ⟹ monom_mult c t b ∈ pmdl B"
by (intro pmdl_closed_monom_mult pmdl.span_base)
lemma pmdl_induct [consumes 1, case_names module_0 module_plus]:
assumes "p ∈ pmdl B" and "P 0"
and "⋀a p c t. a ∈ pmdl B ⟹ P a ⟹ p ∈ B ⟹ c ≠ 0 ⟹ P (a + monom_mult c t p)"
shows "P p"
using assms(1)
proof (induct p rule: pmdl.span_induct')
case base
from assms(2) show ?case .
next
case (step a q b)
from this(1) this(2) show ?case
proof (induct q arbitrary: a rule: poly_mapping_except_induct)
case 1
thus ?case by simp
next
case step: (2 q0 t)
from this(4) step(5) ‹b ∈ B› have "P (a + monomial (lookup q0 t) t ⊙ b)"
unfolding mult_scalar_monomial
proof (rule assms(3))
from step(2) show "lookup q0 t ≠ 0" by (simp add: in_keys_iff)
qed
with _ have "P ((a + monomial (lookup q0 t) t ⊙ b) + except q0 {t} ⊙ b)"
proof (rule step(3))
from ‹b ∈ B› have "b ∈ pmdl B" by (rule pmdl.span_base)
hence "monomial (lookup q0 t) t ⊙ b ∈ pmdl B" by (rule pmdl.span_scale)
with step(4) show "a + monomial (lookup q0 t) t ⊙ b ∈ pmdl B" by (rule pmdl.span_add)
qed
hence "P (a + (monomial (lookup q0 t) t + except q0 {t}) ⊙ b)" by (simp add: algebra_simps)
thus ?case by (simp only: plus_except[of q0 t, symmetric])
qed
qed
lemma components_pmdl: "component_of_term ` Keys (pmdl B) = component_of_term ` Keys B"
proof
show "component_of_term ` Keys (pmdl B) ⊆ component_of_term ` Keys B"
proof
fix k
assume "k ∈ component_of_term ` Keys (pmdl B)"
then obtain v where "v ∈ Keys (pmdl B)" and "k = component_of_term v" ..
from this(1) obtain b where "b ∈ pmdl B" and "v ∈ keys b" by (rule in_KeysE)
thus "k ∈ component_of_term ` Keys B"
proof (induct b rule: pmdl_induct)
case module_0
thus ?case by simp
next
case ind: (module_plus a p c t)
from ind.prems Poly_Mapping.keys_add have "v ∈ keys a ∪ keys (monom_mult c t p)" ..
thus ?case
proof
assume "v ∈ keys a"
thus ?thesis by (rule ind.hyps(2))
next
assume "v ∈ keys (monom_mult c t p)"
from this keys_monom_mult_subset have "v ∈ (⊕) t ` keys p" ..
then obtain u where "u ∈ keys p" and "v = t ⊕ u" ..
have "k = component_of_term u" by (simp add: ‹k = component_of_term v› ‹v = t ⊕ u› term_simps)
moreover from ‹u ∈ keys p› ind.hyps(3) have "u ∈ Keys B" by (rule in_KeysI)
ultimately show ?thesis ..
qed
qed
qed
next
show "component_of_term ` Keys B ⊆ component_of_term ` Keys (pmdl B)"
by (rule image_mono, rule Keys_mono, fact pmdl.span_superset)
qed
lemma pmdl_idI:
assumes "0 ∈ B" and "⋀b1 b2. b1 ∈ B ⟹ b2 ∈ B ⟹ b1 + b2 ∈ B"
and "⋀c t b. b ∈ B ⟹ monom_mult c t b ∈ B"
shows "pmdl B = B"
proof
show "pmdl B ⊆ B"
proof
fix p
assume "p ∈ pmdl B"
thus "p ∈ B"
proof (induct p rule: pmdl_induct)
case module_0
show ?case by (fact assms(1))
next
case step: (module_plus a b c t)
from step(2) show ?case
proof (rule assms(2))
from step(3) show "monom_mult c t b ∈ B" by (rule assms(3))
qed
qed
qed
qed (fact pmdl.span_superset)
definition full_pmdl :: "'k set ⇒ ('t ⇒⇩0 'b::zero) set"
where "full_pmdl K = {p. component_of_term ` keys p ⊆ K}"
definition is_full_pmdl :: "('t ⇒⇩0 'b::comm_ring_1) set ⇒ bool"
where "is_full_pmdl B ⟷ (∀p. component_of_term ` keys p ⊆ component_of_term ` Keys B ⟶ p ∈ pmdl B)"
lemma full_pmdl_iff: "p ∈ full_pmdl K ⟷ component_of_term ` keys p ⊆ K"
by (simp add: full_pmdl_def)
lemma full_pmdlI:
assumes "⋀v. v ∈ keys p ⟹ component_of_term v ∈ K"
shows "p ∈ full_pmdl K"
using assms by (auto simp add: full_pmdl_iff)
lemma full_pmdlD:
assumes "p ∈ full_pmdl K" and "v ∈ keys p"
shows "component_of_term v ∈ K"
using assms by (auto simp add: full_pmdl_iff)
lemma full_pmdl_empty: "full_pmdl {} = {0}"
by (simp add: full_pmdl_def)
lemma full_pmdl_UNIV: "full_pmdl UNIV = UNIV"
by (simp add: full_pmdl_def)
lemma zero_in_full_pmdl: "0 ∈ full_pmdl K"
by (simp add: full_pmdl_iff)
lemma full_pmdl_closed_plus:
assumes "p ∈ full_pmdl K" and "q ∈ full_pmdl K"
shows "p + q ∈ full_pmdl K"
proof (rule full_pmdlI)
fix v
assume "v ∈ keys (p + q)"
also have "... ⊆ keys p ∪ keys q" by (fact Poly_Mapping.keys_add)
finally show "component_of_term v ∈ K"
proof
assume "v ∈ keys p"
with assms(1) show ?thesis by (rule full_pmdlD)
next
assume "v ∈ keys q"
with assms(2) show ?thesis by (rule full_pmdlD)
qed
qed
lemma full_pmdl_closed_monom_mult:
assumes "p ∈ full_pmdl K"
shows "monom_mult c t p ∈ full_pmdl K"
proof (rule full_pmdlI)
fix v
assume "v ∈ keys (monom_mult c t p)"
also have "... ⊆ (⊕) t ` keys p" by (fact keys_monom_mult_subset)
finally obtain u where "u ∈ keys p" and v: "v = t ⊕ u" ..
have "component_of_term v = component_of_term u" by (simp add: v term_simps)
also from assms ‹u ∈ keys p› have "... ∈ K" by (rule full_pmdlD)
finally show "component_of_term v ∈ K" .
qed
lemma pmdl_full_pmdl: "pmdl (full_pmdl K) = full_pmdl K"
using zero_in_full_pmdl full_pmdl_closed_plus full_pmdl_closed_monom_mult by (rule pmdl_idI)
lemma components_full_pmdl_subset:
"component_of_term ` Keys ((full_pmdl K)::('t ⇒⇩0 'b::zero) set) ⊆ K" (is "?l ⊆ _")
proof
let ?M = "(full_pmdl K)::('t ⇒⇩0 'b) set"
fix k
assume "k ∈ ?l"
then obtain v where "v ∈ Keys ?M" and k: "k = component_of_term v" ..
from this(1) obtain p where "p ∈ ?M" and "v ∈ keys p" by (rule in_KeysE)
thus "k ∈ K" unfolding k by (rule full_pmdlD)
qed
lemma components_full_pmdl:
"component_of_term ` Keys ((full_pmdl K)::('t ⇒⇩0 'b::zero_neq_one) set) = K" (is "?l = _")
proof
let ?M = "(full_pmdl K)::('t ⇒⇩0 'b) set"
show "K ⊆ ?l"
proof
fix k
assume "k ∈ K"
hence "monomial 1 (term_of_pair (0, k)) ∈ ?M" by (simp add: full_pmdl_iff term_simps)
hence "keys (monomial (1::'b) (term_of_pair (0, k))) ⊆ Keys ?M" by (rule keys_subset_Keys)
hence "term_of_pair (0, k) ∈ Keys ?M" by simp
hence "component_of_term (term_of_pair (0, k)) ∈ component_of_term ` Keys ?M" by (rule imageI)
thus "k ∈ ?l" by (simp only: component_of_term_of_pair)
qed
qed (fact components_full_pmdl_subset)
lemma is_full_pmdlI:
assumes "⋀p. component_of_term ` keys p ⊆ component_of_term ` Keys B ⟹ p ∈ pmdl B"
shows "is_full_pmdl B"
unfolding is_full_pmdl_def using assms by blast
lemma is_full_pmdlD:
assumes "is_full_pmdl B" and "component_of_term ` keys p ⊆ component_of_term ` Keys B"
shows "p ∈ pmdl B"
using assms unfolding is_full_pmdl_def by blast
lemma is_full_pmdl_alt: "is_full_pmdl B ⟷ pmdl B = full_pmdl (component_of_term ` Keys B)"
proof -
have "b ∈ pmdl B ⟹ v ∈ keys b ⟹ component_of_term v ∈ component_of_term ` Keys B" for b v
by (metis components_pmdl image_eqI in_KeysI)
thus ?thesis by (auto simp add: is_full_pmdl_def full_pmdl_def)
qed
lemma is_full_pmdl_pmdl: "is_full_pmdl (pmdl B) ⟷ is_full_pmdl B"
by (simp only: is_full_pmdl_def pmdl.span_span components_pmdl)
lemma is_full_pmdl_subset:
assumes "is_full_pmdl B1" and "is_full_pmdl B2"
and "component_of_term ` Keys B1 ⊆ component_of_term ` Keys B2"
shows "pmdl B1 ⊆ pmdl B2"
proof
fix p
assume "p ∈ pmdl B1"
from assms(2) show "p ∈ pmdl B2"
proof (rule is_full_pmdlD)
have "component_of_term ` keys p ⊆ component_of_term ` Keys (pmdl B1)"
by (rule image_mono, rule keys_subset_Keys, fact)
also have "... = component_of_term ` Keys B1" by (fact components_pmdl)
finally show "component_of_term ` keys p ⊆ component_of_term ` Keys B2" using assms(3)
by (rule subset_trans)
qed
qed
lemma is_full_pmdl_eq:
assumes "is_full_pmdl B1" and "is_full_pmdl B2"
and "component_of_term ` Keys B1 = component_of_term ` Keys B2"
shows "pmdl B1 = pmdl B2"
proof
have "component_of_term ` Keys B1 ⊆ component_of_term ` Keys B2" by (simp add: assms(3))
with assms(1, 2) show "pmdl B1 ⊆ pmdl B2" by (rule is_full_pmdl_subset)
next
have "component_of_term ` Keys B2 ⊆ component_of_term ` Keys B1" by (simp add: assms(3))
with assms(2, 1) show "pmdl B2 ⊆ pmdl B1" by (rule is_full_pmdl_subset)
qed
end
definition map_scale :: "'b ⇒ ('a ⇒⇩0 'b) ⇒ ('a ⇒⇩0 'b::mult_zero)" (infixr "⋅" 71)
where "map_scale c = Poly_Mapping.map ((*) c)"
text ‹If the polynomial mapping ‹p› is interpreted as a power-product, then @{term "c ⋅ p"}
corresponds to exponentiation; if it is interpreted as a (vector-) polynomial, then @{term "c ⋅ p"}
corresponds to multiplication by scalar from the coefficient type.›
lemma lookup_map_scale [simp]: "lookup (c ⋅ p) = (λx. c * lookup p x)"
by (auto simp: map_scale_def map.rep_eq when_def)
lemma map_scale_single [simp]: "k ⋅ Poly_Mapping.single x l = Poly_Mapping.single x (k * l)"
by (simp add: map_scale_def)
lemma map_scale_zero_left [simp]: "0 ⋅ t = 0"
by (rule poly_mapping_eqI) simp
lemma map_scale_zero_right [simp]: "k ⋅ 0 = 0"
by (rule poly_mapping_eqI) simp
lemma map_scale_eq_0_iff: "c ⋅ t = 0 ⟷ ((c::_::semiring_no_zero_divisors) = 0 ∨ t = 0)"
by (metis aux lookup_map_scale mult_eq_0_iff)
lemma keys_map_scale_subset: "keys (k ⋅ t) ⊆ keys t"
by (metis in_keys_iff lookup_map_scale mult_zero_right subsetI)
lemma keys_map_scale: "keys ((k::'b::semiring_no_zero_divisors) ⋅ t) = (if k = 0 then {} else keys t)"
proof (split if_split, intro conjI impI)
assume "k = 0"
thus "keys (k ⋅ t) = {}" by simp
next
assume "k ≠ 0"
show "keys (k ⋅ t) = keys t"
proof
show "keys t ⊆ keys (k ⋅ t)" by rule (simp add: ‹k ≠ 0› flip: lookup_not_eq_zero_eq_in_keys)
qed (fact keys_map_scale_subset)
qed
lemma map_scale_one_left [simp]: "(1::'b::{mult_zero,monoid_mult}) ⋅ t = t"
by (rule poly_mapping_eqI) simp
lemma map_scale_assoc [ac_simps]: "c ⋅ d ⋅ t = (c * d) ⋅ (t::_ ⇒⇩0 _::{semigroup_mult,zero})"
by (rule poly_mapping_eqI) (simp add: ac_simps)
lemma map_scale_distrib_left [algebra_simps]: "(k::'b::semiring_0) ⋅ (s + t) = k ⋅ s + k ⋅ t"
by (rule poly_mapping_eqI) (simp add: lookup_add distrib_left)
lemma map_scale_distrib_right [algebra_simps]: "(k + (l::'b::semiring_0)) ⋅ t = k ⋅ t + l ⋅ t"
by (rule poly_mapping_eqI) (simp add: lookup_add distrib_right)
lemma map_scale_Suc: "(Suc k) ⋅ t = k ⋅ t + t"
by (rule poly_mapping_eqI) (simp add: lookup_add distrib_right)
lemma map_scale_uminus_left: "(- k::'b::ring) ⋅ p = - (k ⋅ p)"
by (rule poly_mapping_eqI) auto
lemma map_scale_uminus_right: "(k::'b::ring) ⋅ (- p) = - (k ⋅ p)"
by (rule poly_mapping_eqI) auto
lemma map_scale_uminus_uminus [simp]: "(- k::'b::ring) ⋅ (- p) = k ⋅ p"
by (simp add: map_scale_uminus_left map_scale_uminus_right)
lemma map_scale_minus_distrib_left [algebra_simps]:
"(k::'b::comm_semiring_1_cancel) ⋅ (p - q) = k ⋅ p - k ⋅ q"
by (rule poly_mapping_eqI) (auto simp add: lookup_minus right_diff_distrib')
lemma map_scale_minus_distrib_right [algebra_simps]:
"(k - (l::'b::comm_semiring_1_cancel)) ⋅ f = k ⋅ f - l ⋅ f"
by (rule poly_mapping_eqI) (auto simp add: lookup_minus left_diff_distrib')
lemma map_scale_sum_distrib_left: "(k::'b::semiring_0) ⋅ (sum f A) = (∑a∈A. k ⋅ f a)"
by (induct A rule: infinite_finite_induct) (simp_all add: map_scale_distrib_left)
lemma map_scale_sum_distrib_right: "(sum (f::_ ⇒ 'b::semiring_0) A) ⋅ p = (∑a∈A. f a ⋅ p)"
by (induct A rule: infinite_finite_induct) (simp_all add: map_scale_distrib_right)
lemma deg_pm_map_scale: "deg_pm (k ⋅ t) = (k::'b::semiring_0) * deg_pm t"
proof -
from keys_map_scale_subset finite_keys have "deg_pm (k ⋅ t) = sum (lookup (k ⋅ t)) (keys t)"
by (rule deg_pm_superset)
also have "… = k * sum (lookup t) (keys t)" by (simp add: sum_distrib_left)
also from subset_refl finite_keys have "sum (lookup t) (keys t) = deg_pm t"
by (rule deg_pm_superset[symmetric])
finally show ?thesis .
qed
interpretation phull: module map_scale
apply standard
subgoal by (fact map_scale_distrib_left)
subgoal by (fact map_scale_distrib_right)
subgoal by (fact map_scale_assoc)
subgoal by (fact map_scale_one_left)
done
text ‹Since the following lemmas are proved for more general ring-types above, we do not need to
have them in the simpset.›
lemmas [simp del] = phull.scale_one phull.scale_zero_left phull.scale_zero_right phull.scale_scale
phull.scale_minus_left phull.scale_minus_right phull.span_eq_iff
lemmas [algebra_simps del] = phull.scale_left_distrib phull.scale_right_distrib
phull.scale_left_diff_distrib phull.scale_right_diff_distrib
abbreviation "phull ≡ phull.span"
text ‹@{term ‹phull B›} is a module over the coefficient ring @{typ 'b}, whereas
@{term ‹term_powerprod.pmdl B›} is a module over the (scalar) polynomial ring @{typ ‹'a ⇒⇩0 'b›}.
Nevertheless, both modules can be sets of @{emph ‹vector-polynomials›} of type @{typ ‹'t ⇒⇩0 'b›}.›
context term_powerprod
begin
lemma map_scale_eq_monom_mult: "c ⋅ p = monom_mult c 0 p"
by (rule poly_mapping_eqI) (simp only: lookup_map_scale lookup_monom_mult_zero)
lemma map_scale_eq_mult_scalar: "c ⋅ p = monomial c 0 ⊙ p"
by (simp only: map_scale_eq_monom_mult mult_scalar_monomial)
lemma phull_closed_mult_scalar: "p ∈ phull B ⟹ monomial c 0 ⊙ p ∈ phull B"
unfolding map_scale_eq_mult_scalar[symmetric] by (rule phull.span_scale)
lemma mult_scalar_in_phull: "b ∈ B ⟹ monomial c 0 ⊙ b ∈ phull B"
by (intro phull_closed_mult_scalar phull.span_base)
lemma phull_subset_module: "phull B ⊆ pmdl B"
proof
fix p
assume "p ∈ phull B"
thus "p ∈ pmdl B"
proof (induct p rule: phull.span_induct')
case base
show ?case by (fact pmdl.span_zero)
next
case (step a c p)
from step(3) have "p ∈ pmdl B" by (rule pmdl.span_base)
hence "c ⋅ p ∈ pmdl B" unfolding map_scale_eq_monom_mult by (rule pmdl_closed_monom_mult)
with step(2) show ?case by (rule pmdl.span_add)
qed
qed
lemma components_phull: "component_of_term ` Keys (phull B) = component_of_term ` Keys B"
proof
have "component_of_term ` Keys (phull B) ⊆ component_of_term ` Keys (pmdl B)"
by (rule image_mono, rule Keys_mono, fact phull_subset_module)
also have "... = component_of_term ` Keys B" by (fact components_pmdl)
finally show "component_of_term ` Keys (phull B) ⊆ component_of_term ` Keys B" .
next
show "component_of_term ` Keys B ⊆ component_of_term ` Keys (phull B)"
by (rule image_mono, rule Keys_mono, fact phull.span_superset)
qed
end
subsection ‹Interpretations›
subsubsection ‹Isomorphism between @{typ 'a} and @{typ "'a × unit"}›
definition to_pair_unit :: "'a ⇒ ('a × unit)"
where "to_pair_unit x = (x, ())"
lemma fst_to_pair_unit: "fst (to_pair_unit x) = x"
by (simp add: to_pair_unit_def)
lemma to_pair_unit_fst: "to_pair_unit (fst x) = (x::_ × unit)"
by (metis (full_types) old.unit.exhaust prod.collapse to_pair_unit_def)
interpretation punit: term_powerprod to_pair_unit fst
apply standard
subgoal by (fact fst_to_pair_unit)
subgoal by (fact to_pair_unit_fst)
done
text ‹For technical reasons it seems to be better not to put the following lemmas as rewrite-rules
of interpretation ‹punit›.›
lemma punit_pp_of_term [simp]: "punit.pp_of_term = (λx. x)"
by (rule, simp add: punit.pp_of_term_def punit.term_pair)
lemma punit_component_of_term [simp]: "punit.component_of_term = (λ_. ())"
by (rule, simp add: punit.component_of_term_def)
lemma punit_splus [simp]: "punit.splus = (+)"
by (rule, rule, simp add: punit.splus_def)
lemma punit_sminus [simp]: "punit.sminus = (-)"
by (rule, rule, simp add: punit.sminus_def)
lemma punit_adds_pp [simp]: "punit.adds_pp = (adds)"
by (rule, rule, simp add: punit.adds_pp_def)
lemma punit_adds_term [simp]: "punit.adds_term = (adds)"
by (rule, rule, simp add: punit.adds_term_def)
lemma punit_proj_poly [simp]: "punit.proj_poly = (λ_. id)"
by (rule, rule, rule poly_mapping_eqI, simp add: punit.lookup_proj_poly)
lemma punit_mult_vec [simp]: "punit.mult_vec = (*)"
by (rule, rule, rule poly_mapping_eqI, simp add: punit.lookup_mult_vec)
lemma punit_mult_scalar [simp]: "punit.mult_scalar = (*)"
by (rule, rule, rule poly_mapping_eqI, simp add: punit.lookup_mult_scalar)
context term_powerprod
begin
lemma proj_monom_mult: "proj_poly k (monom_mult c t p) = punit.monom_mult c t (proj_poly k p)"
by (metis mult_scalar_monomial proj_mult_scalar punit.mult_scalar_monomial punit_mult_scalar)
lemma mult_scalar_monom_mult: "(punit.monom_mult c t p) ⊙ q = monom_mult c t (p ⊙ q)"
by (simp add: punit.mult_scalar_monomial[symmetric] mult_scalar_assoc mult_scalar_monomial)
end
subsubsection ‹Interpretation of @{locale term_powerprod} by @{typ "'a × 'k"}›
interpretation pprod: term_powerprod "(λx::'a::comm_powerprod × 'k::linorder. x)" "λx. x"
by (standard, simp)
lemma pprod_pp_of_term [simp]: "pprod.pp_of_term = fst"
by (rule, simp add: pprod.pp_of_term_def)
lemma pprod_component_of_term [simp]: "pprod.component_of_term = snd"
by (rule, simp add: pprod.component_of_term_def)
subsubsection ‹Simplifier Setup›
text ‹There is no reason to keep the interpreted theorems as simplification rules.›
lemmas [term_simps del] = term_simps
lemmas times_monomial_monomial = punit.mult_scalar_monomial_monomial[simplified]
lemmas times_monomial_left = punit.mult_scalar_monomial[simplified]
lemmas times_rec_left = punit.mult_scalar_rec_left[simplified]
lemmas times_rec_right = punit.mult_scalar_rec_right[simplified]
lemmas in_keys_timesE = punit.in_keys_mult_scalarE[simplified]
lemmas punit_monom_mult_monomial = punit.monom_mult_monomial[simplified]
lemmas lookup_times = punit.lookup_mult_scalar_explicit[simplified]
lemmas map_scale_eq_times = punit.map_scale_eq_mult_scalar[simplified]
end
Theory MPoly_Type_Class_Ordered
section ‹Type-Class-Multivariate Polynomials in Ordered Terms›
theory MPoly_Type_Class_Ordered
imports MPoly_Type_Class
begin
class the_min = linorder +
fixes the_min::'a
assumes the_min_min: "the_min ≤ x"
text ‹Type class @{class the_min} guarantees that a least element exists. Instances of @{class the_min}
should provide @{emph ‹computable›} definitions of that element.›
instantiation nat :: the_min
begin
definition "the_min_nat = (0::nat)"
instance by (standard, simp add: the_min_nat_def)
end
instantiation unit :: the_min
begin
definition "the_min_unit = ()"
instance by (standard, simp add: the_min_unit_def)
end
locale ordered_term =
term_powerprod pair_of_term term_of_pair +
ordered_powerprod ord ord_strict +
ord_term_lin: linorder ord_term ord_term_strict
for pair_of_term::"'t ⇒ ('a::comm_powerprod × 'k::{the_min,wellorder})"
and term_of_pair::"('a × 'k) ⇒ 't"
and ord::"'a ⇒ 'a ⇒ bool" (infixl "≼" 50)
and ord_strict (infixl "≺" 50)
and ord_term::"'t ⇒ 't ⇒ bool" (infixl "≼⇩t" 50)
and ord_term_strict::"'t ⇒ 't ⇒ bool" (infixl "≺⇩t" 50) +
assumes splus_mono: "v ≼⇩t w ⟹ t ⊕ v ≼⇩t t ⊕ w"
assumes ord_termI: "pp_of_term v ≼ pp_of_term w ⟹ component_of_term v ≤ component_of_term w ⟹ v ≼⇩t w"
begin
abbreviation ord_term_conv (infixl "≽⇩t" 50) where "ord_term_conv ≡ (≼⇩t)¯¯"
abbreviation ord_term_strict_conv (infixl "≻⇩t" 50) where "ord_term_strict_conv ≡ (≺⇩t)¯¯"
text ‹The definition of @{locale ordered_term} only covers TOP and POT orderings.
These two types of orderings are the only interesting ones.›
definition "min_term ≡ term_of_pair (0, the_min)"
lemma min_term_min: "min_term ≼⇩t v"
proof (rule ord_termI)
show "pp_of_term min_term ≼ pp_of_term v" by (simp add: min_term_def zero_min term_simps)
next
show "component_of_term min_term ≤ component_of_term v" by (simp add: min_term_def the_min_min term_simps)
qed
lemma splus_mono_strict:
assumes "v ≺⇩t w"
shows "t ⊕ v ≺⇩t t ⊕ w"
proof -
from assms have "v ≼⇩t w" and "v ≠ w" by simp_all
from this(1) have "t ⊕ v ≼⇩t t ⊕ w" by (rule splus_mono)
moreover from ‹v ≠ w› have "t ⊕ v ≠ t ⊕ w" by (simp add: term_simps)
ultimately show ?thesis using ord_term_lin.antisym_conv1 by blast
qed
lemma splus_mono_left:
assumes "s ≼ t"
shows "s ⊕ v ≼⇩t t ⊕ v"
proof (rule ord_termI, simp_all add: term_simps)
from assms show "s + pp_of_term v ≼ t + pp_of_term v" by (rule plus_monotone)
qed
lemma splus_mono_strict_left:
assumes "s ≺ t"
shows "s ⊕ v ≺⇩t t ⊕ v"
proof -
from assms have "s ≼ t" and "s ≠ t" by simp_all
from this(1) have "s ⊕ v ≼⇩t t ⊕ v" by (rule splus_mono_left)
moreover from ‹s ≠ t› have "s ⊕ v ≠ t ⊕ v" by (simp add: term_simps)
ultimately show ?thesis using ord_term_lin.antisym_conv1 by blast
qed
lemma ord_term_canc:
assumes "t ⊕ v ≼⇩t t ⊕ w"
shows "v ≼⇩t w"
proof (rule ccontr)
assume "¬ v ≼⇩t w"
hence "w ≺⇩t v" by simp
hence "t ⊕ w ≺⇩t t ⊕ v" by (rule splus_mono_strict)
with assms show False by simp
qed
lemma ord_term_strict_canc:
assumes "t ⊕ v ≺⇩t t ⊕ w"
shows "v ≺⇩t w"
proof (rule ccontr)
assume "¬ v ≺⇩t w"
hence "w ≼⇩t v" by simp
hence "t ⊕ w ≼⇩t t ⊕ v" by (rule splus_mono)
with assms show False by simp
qed
lemma ord_term_canc_left:
assumes "t ⊕ v ≼⇩t s ⊕ v"
shows "t ≼ s"
proof (rule ccontr)
assume "¬ t ≼ s"
hence "s ≺ t" by simp
hence "s ⊕ v ≺⇩t t ⊕ v" by (rule splus_mono_strict_left)
with assms show False by simp
qed
lemma ord_term_strict_canc_left:
assumes "t ⊕ v ≺⇩t s ⊕ v"
shows "t ≺ s"
proof (rule ccontr)
assume "¬ t ≺ s"
hence "s ≼ t" by simp
hence "s ⊕ v ≼⇩t t ⊕ v" by (rule splus_mono_left)
with assms show False by simp
qed
lemma ord_adds_term:
assumes "u adds⇩t v"
shows "u ≼⇩t v"
proof -
from assms have *: "component_of_term u ≤ component_of_term v" and "pp_of_term u adds pp_of_term v"
by (simp_all add: adds_term_def)
from this(2) have "pp_of_term u ≼ pp_of_term v" by (rule ord_adds)
from this * show ?thesis by (rule ord_termI)
qed
end
subsection ‹Interpretations›
context ordered_powerprod
begin
subsubsection ‹Unit›
sublocale punit: ordered_term to_pair_unit fst "(≼)" "(≺)" "(≼)" "(≺)"
apply standard
subgoal by (simp, fact plus_monotone_left)
subgoal by (simp only: punit_pp_of_term punit_component_of_term)
done
lemma punit_min_term [simp]: "punit.min_term = 0"
by (simp add: punit.min_term_def)
end
subsection ‹Definitions›
context ordered_term
begin
definition higher :: "('t ⇒⇩0 'b) ⇒ 't ⇒ ('t ⇒⇩0 'b::zero)"
where "higher p t = except p {s. s ≼⇩t t}"
definition lower :: "('t ⇒⇩0 'b) ⇒ 't ⇒ ('t ⇒⇩0 'b::zero)"
where "lower p t = except p {s. t ≼⇩t s}"
definition lt :: "('t ⇒⇩0 'b::zero) ⇒ 't"
where "lt p = (if p = 0 then min_term else ord_term_lin.Max (keys p))"
abbreviation "lp p ≡ pp_of_term (lt p)"
definition lc :: "('t ⇒⇩0 'b::zero) ⇒ 'b"
where "lc p = lookup p (lt p)"
definition tt :: "('t ⇒⇩0 'b::zero) ⇒ 't"
where "tt p = (if p = 0 then min_term else ord_term_lin.Min (keys p))"
abbreviation "tp p ≡ pp_of_term (tt p)"
definition tc :: "('t ⇒⇩0 'b::zero) ⇒ 'b"
where "tc p ≡ lookup p (tt p)"
definition tail :: "('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::zero)"
where "tail p ≡ lower p (lt p)"
subsection ‹Leading Term and Leading Coefficient: @{const lt} and @{const lc}›
lemma lt_zero [simp]: "lt 0 = min_term"
by (simp add: lt_def)
lemma lc_zero [simp]: "lc 0 = 0"
by (simp add: lc_def)
lemma lt_uminus [simp]: "lt (- p) = lt p"
by (simp add: lt_def keys_uminus)
lemma lc_uminus [simp]: "lc (- p) = - lc p"
by (simp add: lc_def)
lemma lt_alt:
assumes "p ≠ 0"
shows "lt p = ord_term_lin.Max (keys p)"
using assms unfolding lt_def by simp
lemma lt_max:
assumes "lookup p v ≠ 0"
shows "v ≼⇩t lt p"
proof -
from assms have t_in: "v ∈ keys p" by (simp add: in_keys_iff)
hence "keys p ≠ {}" by auto
hence "p ≠ 0" using keys_zero by blast
from lt_alt[OF this] ord_term_lin.Max_ge[OF finite_keys t_in] show ?thesis by simp
qed
lemma lt_eqI:
assumes "lookup p v ≠ 0" and "⋀u. lookup p u ≠ 0 ⟹ u ≼⇩t v"
shows "lt p = v"
proof -
from assms(1) have "v ∈ keys p" by (simp add: in_keys_iff)
hence "keys p ≠ {}" by auto
hence "p ≠ 0"
using keys_zero by blast
have "u ≼⇩t v" if "u ∈ keys p" for u
proof -
from that have "lookup p u ≠ 0" by (simp add: in_keys_iff)
thus "u ≼⇩t v" by (rule assms(2))
qed
from lt_alt[OF ‹p ≠ 0›] ord_term_lin.Max_eqI[OF finite_keys this ‹v ∈ keys p›] show ?thesis by simp
qed
lemma lt_less:
assumes "p ≠ 0" and "⋀u. v ≼⇩t u ⟹ lookup p u = 0"
shows "lt p ≺⇩t v"
proof -
from ‹p ≠ 0› have "keys p ≠ {}"
by simp
have "∀u∈keys p. u ≺⇩t v"
proof
fix u::'t
assume "u ∈ keys p"
hence "lookup p u ≠ 0" by (simp add: in_keys_iff)
hence "¬ v ≼⇩t u" using assms(2)[of u] by auto
thus "u ≺⇩t v" by simp
qed
with lt_alt[OF assms(1)] ord_term_lin.Max_less_iff[OF finite_keys ‹keys p ≠ {}›] show ?thesis by simp
qed
lemma lt_le:
assumes "⋀u. v ≺⇩t u ⟹ lookup p u = 0"
shows "lt p ≼⇩t v"
proof (cases "p = 0")
case True
show ?thesis by (simp add: True min_term_min)
next
case False
hence "keys p ≠ {}" by simp
have "∀u∈keys p. u ≼⇩t v"
proof
fix u::'t
assume "u ∈ keys p"
hence "lookup p u ≠ 0" unfolding keys_def by simp
hence "¬ v ≺⇩t u" using assms[of u] by auto
thus "u ≼⇩t v" by simp
qed
with lt_alt[OF False] ord_term_lin.Max_le_iff[OF finite_keys[of p] ‹keys p ≠ {}›]
show ?thesis by simp
qed
lemma lt_gr:
assumes "lookup p s ≠ 0" and "t ≺⇩t s"
shows "t ≺⇩t lt p"
using assms lt_max ord_term_lin.order.strict_trans2 by blast
lemma lc_not_0:
assumes "p ≠ 0"
shows "lc p ≠ 0"
proof -
from keys_zero assms have "keys p ≠ {}" by auto
from lt_alt[OF assms] ord_term_lin.Max_in[OF finite_keys this] show ?thesis by (simp add: in_keys_iff lc_def)
qed
lemma lc_eq_zero_iff: "lc p = 0 ⟷ p = 0"
using lc_not_0 lc_zero by blast
lemma lt_in_keys:
assumes "p ≠ 0"
shows "lt p ∈ (keys p)"
by (metis assms in_keys_iff lc_def lc_not_0)
lemma lt_monomial:
assumes "c ≠ 0"
shows "lt (monomial c t) = t"
by (metis assms lookup_single_eq lookup_single_not_eq lt_eqI ord_term_lin.eq_iff)
lemma lc_monomial [simp]: "lc (monomial c t) = c"
proof (cases "c = 0")
case True
thus ?thesis by simp
next
case False
thus ?thesis by (simp add: lc_def lt_monomial)
qed
lemma lt_le_iff: "lt p ≼⇩t v ⟷ (∀u. v ≺⇩t u ⟶ lookup p u = 0)" (is "?L ⟷ ?R")
proof
assume ?L
show ?R
proof (intro allI impI)
fix u
note ‹lt p ≼⇩t v›
also assume "v ≺⇩t u"
finally have "lt p ≺⇩t u" .
hence "¬ u ≼⇩t lt p" by simp
with lt_max[of p u] show "lookup p u = 0" by blast
qed
next
assume ?R
thus ?L using lt_le by auto
qed
lemma lt_plus_eqI:
assumes "lt p ≺⇩t lt q"
shows "lt (p + q) = lt q"
proof (cases "q = 0")
case True
with assms have "lt p ≺⇩t min_term" by (simp add: lt_def)
with min_term_min[of "lt p"] show ?thesis by simp
next
case False
show ?thesis
proof (intro lt_eqI)
from lt_gr[of p "lt q" "lt p"] assms have "lookup p (lt q) = 0" by blast
with lookup_add[of p q "lt q"] lc_not_0[OF False] show "lookup (p + q) (lt q) ≠ 0"
unfolding lc_def by simp
next
fix u
assume "lookup (p + q) u ≠ 0"
show "u ≼⇩t lt q"
proof (rule ccontr)
assume "¬ u ≼⇩t lt q"
hence qs: "lt q ≺⇩t u" by simp
with assms have "lt p ≺⇩t u" by simp
with lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
moreover from qs lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
ultimately show False using ‹lookup (p + q) u ≠ 0› lookup_add[of p q u] by auto
qed
qed
qed
lemma lt_plus_eqI_2:
assumes "lt q ≺⇩t lt p"
shows "lt (p + q) = lt p"
proof (cases "p = 0")
case True
with assms have "lt q ≺⇩t min_term" by (simp add: lt_def)
with min_term_min[of "lt q"] show ?thesis by simp
next
case False
show ?thesis
proof (intro lt_eqI)
from lt_gr[of q "lt p" "lt q"] assms have "lookup q (lt p) = 0" by blast
with lookup_add[of p q "lt p"] lc_not_0[OF False] show "lookup (p + q) (lt p) ≠ 0"
unfolding lc_def by simp
next
fix u
assume "lookup (p + q) u ≠ 0"
show "u ≼⇩t lt p"
proof (rule ccontr)
assume "¬ u ≼⇩t lt p"
hence ps: "lt p ≺⇩t u" by simp
with assms have "lt q ≺⇩t u" by simp
with lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
also from ps lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
ultimately show False using ‹lookup (p + q) u ≠ 0› lookup_add[of p q u] by auto
qed
qed
qed
lemma lt_plus_eqI_3:
assumes "lt q = lt p" and "lc p + lc q ≠ 0"
shows "lt (p + q) = lt (p::'t ⇒⇩0 'b::monoid_add)"
proof (rule lt_eqI)
from assms(2) show "lookup (p + q) (lt p) ≠ 0" by (simp add: lookup_add lc_def assms(1))
next
fix u
assume "lookup (p + q) u ≠ 0"
hence "lookup p u + lookup q u ≠ 0" by (simp add: lookup_add)
hence "lookup p u ≠ 0 ∨ lookup q u ≠ 0" by auto
thus "u ≼⇩t lt p"
proof
assume "lookup p u ≠ 0"
thus ?thesis by (rule lt_max)
next
assume "lookup q u ≠ 0"
hence "u ≼⇩t lt q" by (rule lt_max)
thus ?thesis by (simp only: assms(1))
qed
qed
lemma lt_plus_lessE:
assumes "lt p ≺⇩t lt (p + q)"
shows "lt p ≺⇩t lt q"
proof (rule ccontr)
assume "¬ lt p ≺⇩t lt q"
hence "lt p = lt q ∨ lt q ≺⇩t lt p" by auto
thus False
proof
assume lt_eq: "lt p = lt q"
have "lt (p + q) ≼⇩t lt p"
proof (rule lt_le)
fix u
assume "lt p ≺⇩t u"
with lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
from ‹lt p ≺⇩t u› have "lt q ≺⇩t u" using lt_eq by simp
with lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
with ‹lookup p u = 0› show "lookup (p + q) u = 0" by (simp add: lookup_add)
qed
with assms show False by simp
next
assume "lt q ≺⇩t lt p"
from lt_plus_eqI_2[OF this] assms show False by simp
qed
qed
lemma lt_plus_lessE_2:
assumes "lt q ≺⇩t lt (p + q)"
shows "lt q ≺⇩t lt p"
proof (rule ccontr)
assume "¬ lt q ≺⇩t lt p"
hence "lt q = lt p ∨ lt p ≺⇩t lt q" by auto
thus False
proof
assume lt_eq: "lt q = lt p"
have "lt (p + q) ≼⇩t lt q"
proof (rule lt_le)
fix u
assume "lt q ≺⇩t u"
with lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
from ‹lt q ≺⇩t u› have "lt p ≺⇩t u" using lt_eq by simp
with lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
with ‹lookup q u = 0› show "lookup (p + q) u = 0" by (simp add: lookup_add)
qed
with assms show False by simp
next
assume "lt p ≺⇩t lt q"
from lt_plus_eqI[OF this] assms show False by simp
qed
qed
lemma lt_plus_lessI':
fixes p q :: "'t ⇒⇩0 'b::monoid_add"
assumes "p + q ≠ 0" and lt_eq: "lt q = lt p" and lc_eq: "lc p + lc q = 0"
shows "lt (p + q) ≺⇩t lt p"
proof (rule ccontr)
assume "¬ lt (p + q) ≺⇩t lt p"
hence "lt (p + q) = lt p ∨ lt p ≺⇩t lt (p + q)" by auto
thus False
proof
assume "lt (p + q) = lt p"
have "lookup (p + q) (lt p) = (lookup p (lt p)) + (lookup q (lt q))" unfolding lt_eq lookup_add ..
also have "... = lc p + lc q" unfolding lc_def ..
also have "... = 0" unfolding lc_eq by simp
finally have "lookup (p + q) (lt p) = 0" .
hence "lt (p + q) ≠ lt p" using lc_not_0[OF ‹p + q ≠ 0›] unfolding lc_def by auto
with ‹lt (p + q) = lt p› show False by simp
next
assume "lt p ≺⇩t lt (p + q)"
have "lt p ≺⇩t lt q" by (rule lt_plus_lessE, fact+)
hence "lt p ≠ lt q" by simp
with lt_eq show False by simp
qed
qed
corollary lt_plus_lessI:
fixes p q :: "'t ⇒⇩0 'b::group_add"
assumes "p + q ≠ 0" and "lt q = lt p" and "lc q = - lc p"
shows "lt (p + q) ≺⇩t lt p"
using assms(1, 2)
proof (rule lt_plus_lessI')
from assms(3) show "lc p + lc q = 0" by simp
qed
lemma lt_plus_distinct_eq_max:
assumes "lt p ≠ lt q"
shows "lt (p + q) = ord_term_lin.max (lt p) (lt q)"
proof (rule ord_term_lin.linorder_cases)
assume a: "lt p ≺⇩t lt q"
hence "lt (p + q) = lt q" by (rule lt_plus_eqI)
also from a have "... = ord_term_lin.max (lt p) (lt q)"
by (simp add: ord_term_lin.max.absorb2)
finally show ?thesis .
next
assume a: "lt q ≺⇩t lt p"
hence "lt (p + q) = lt p" by (rule lt_plus_eqI_2)
also from a have "... = ord_term_lin.max (lt p) (lt q)"
by (simp add: ord_term_lin.max.absorb1)
finally show ?thesis .
next
assume "lt p = lt q"
with assms show ?thesis ..
qed
lemma lt_plus_le_max: "lt (p + q) ≼⇩t ord_term_lin.max (lt p) (lt q)"
proof (cases "lt p = lt q")
case True
show ?thesis
proof (rule lt_le)
fix u
assume "ord_term_lin.max (lt p) (lt q) ≺⇩t u"
hence "lt p ≺⇩t u" and "lt q ≺⇩t u" by simp_all
hence "lookup p u = 0" and "lookup q u = 0" using lt_max ord_term_lin.leD by blast+
thus "lookup (p + q) u = 0" by (simp add: lookup_add)
qed
next
case False
hence "lt (p + q) = ord_term_lin.max (lt p) (lt q)" by (rule lt_plus_distinct_eq_max)
thus ?thesis by simp
qed
lemma lt_minus_eqI: "lt p ≺⇩t lt q ⟹ lt (p - q) = lt q" for p q :: "'t ⇒⇩0 'b::ab_group_add"
by (metis lt_plus_eqI_2 lt_uminus uminus_add_conv_diff)
lemma lt_minus_eqI_2: "lt q ≺⇩t lt p ⟹ lt (p - q) = lt p" for p q :: "'t ⇒⇩0 'b::ab_group_add"
by (metis lt_minus_eqI lt_uminus minus_diff_eq)
lemma lt_minus_eqI_3:
assumes "lt q = lt p" and "lc q ≠ lc p"
shows "lt (p - q) = lt (p::'t ⇒⇩0 'b::ab_group_add)"
proof (rule lt_eqI)
from assms(2) show "lookup (p - q) (lt p) ≠ 0" by (simp add: lookup_minus lc_def assms(1))
next
fix u
assume "lookup (p - q) u ≠ 0"
hence "lookup p u ≠ lookup q u" by (simp add: lookup_minus)
hence "lookup p u ≠ 0 ∨ lookup q u ≠ 0" by auto
thus "u ≼⇩t lt p"
proof
assume "lookup p u ≠ 0"
thus ?thesis by (rule lt_max)
next
assume "lookup q u ≠ 0"
hence "u ≼⇩t lt q" by (rule lt_max)
thus ?thesis by (simp only: assms(1))
qed
qed
lemma lt_minus_distinct_eq_max:
assumes "lt p ≠ lt (q::'t ⇒⇩0 'b::ab_group_add)"
shows "lt (p - q) = ord_term_lin.max (lt p) (lt q)"
proof (rule ord_term_lin.linorder_cases)
assume a: "lt p ≺⇩t lt q"
hence "lt (p - q) = lt q" by (rule lt_minus_eqI)
also from a have "... = ord_term_lin.max (lt p) (lt q)"
by (simp add: ord_term_lin.max.absorb2)
finally show ?thesis .
next
assume a: "lt q ≺⇩t lt p"
hence "lt (p - q) = lt p" by (rule lt_minus_eqI_2)
also from a have "... = ord_term_lin.max (lt p) (lt q)"
by (simp add: ord_term_lin.max.absorb1)
finally show ?thesis .
next
assume "lt p = lt q"
with assms show ?thesis ..
qed
lemma lt_minus_lessE: "lt p ≺⇩t lt (p - q) ⟹ lt p ≺⇩t lt q" for p q :: "'t ⇒⇩0 'b::ab_group_add"
using lt_minus_eqI_2 by fastforce
lemma lt_minus_lessE_2: "lt q ≺⇩t lt (p - q) ⟹ lt q ≺⇩t lt p" for p q :: "'t ⇒⇩0 'b::ab_group_add"
using lt_plus_eqI_2 by fastforce
lemma lt_minus_lessI: "p - q ≠ 0 ⟹ lt q = lt p ⟹ lc q = lc p ⟹ lt (p - q) ≺⇩t lt p"
for p q :: "'t ⇒⇩0 'b::ab_group_add"
by (metis (no_types, hide_lams) diff_diff_eq2 diff_self group_eq_aux lc_def lc_not_0 lookup_minus
lt_minus_eqI ord_term_lin.antisym_conv3)
lemma lt_max_keys:
assumes "v ∈ keys p"
shows "v ≼⇩t lt p"
proof (rule lt_max)
from assms show "lookup p v ≠ 0" by (simp add: in_keys_iff)
qed
lemma lt_eqI_keys:
assumes "v ∈ keys p" and a2: "⋀u. u ∈ keys p ⟹ u ≼⇩t v"
shows "lt p = v"
by (rule lt_eqI, simp_all only: in_keys_iff[symmetric], fact+)
lemma lt_gr_keys:
assumes "u ∈ keys p" and "v ≺⇩t u"
shows "v ≺⇩t lt p"
proof (rule lt_gr)
from assms(1) show "lookup p u ≠ 0" by (simp add: in_keys_iff)
qed fact
lemma lt_plus_eq_maxI:
assumes "lt p = lt q ⟹ lc p + lc q ≠ 0"
shows "lt (p + q) = ord_term_lin.max (lt p) (lt q)"
proof (cases "lt p = lt q")
case True
show ?thesis
proof (rule lt_eqI_keys)
from True have "lc p + lc q ≠ 0" by (rule assms)
thus "ord_term_lin.max (lt p) (lt q) ∈ keys (p + q)"
by (simp add: in_keys_iff lc_def lookup_add True)
next
fix u
assume "u ∈ keys (p + q)"
hence "u ≼⇩t lt (p + q)" by (rule lt_max_keys)
also have "... ≼⇩t ord_term_lin.max (lt p) (lt q)" by (fact lt_plus_le_max)
finally show "u ≼⇩t ord_term_lin.max (lt p) (lt q)" .
qed
next
case False
thus ?thesis by (rule lt_plus_distinct_eq_max)
qed
lemma lt_monom_mult:
assumes "c ≠ (0::'b::semiring_no_zero_divisors)" and "p ≠ 0"
shows "lt (monom_mult c t p) = t ⊕ lt p"
proof (intro lt_eqI)
from assms(1) show "lookup (monom_mult c t p) (t ⊕ lt p) ≠ 0"
proof (simp add: lookup_monom_mult_plus)
show "lookup p (lt p) ≠ 0"
using assms(2) lt_in_keys by auto
qed
next
fix u::'t
assume "lookup (monom_mult c t p) u ≠ 0"
hence "u ∈ keys (monom_mult c t p)" by (simp add: in_keys_iff)
also have "... ⊆ (⊕) t ` keys p" by (fact keys_monom_mult_subset)
finally obtain v where "v ∈ keys p" and "u = t ⊕ v" ..
show "u ≼⇩t t ⊕ lt p" unfolding ‹u = t ⊕ v›
proof (rule splus_mono)
from ‹v ∈ keys p› show "v ≼⇩t lt p" by (rule lt_max_keys)
qed
qed
lemma lt_monom_mult_zero:
assumes "c ≠ (0::'b::semiring_no_zero_divisors)"
shows "lt (monom_mult c 0 p) = lt p"
proof (cases "p = 0")
case True
show ?thesis by (simp add: True)
next
case False
with assms show ?thesis by (simp add: lt_monom_mult term_simps)
qed
corollary lt_map_scale: "c ≠ (0::'b::semiring_no_zero_divisors) ⟹ lt (c ⋅ p) = lt p"
by (simp add: map_scale_eq_monom_mult lt_monom_mult_zero)
lemma lc_monom_mult [simp]: "lc (monom_mult c t p) = (c::'b::semiring_no_zero_divisors) * lc p"
proof (cases "c = 0")
case True
thus ?thesis by simp
next
case False
show ?thesis
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
with ‹c ≠ 0› show ?thesis by (simp add: lc_def lt_monom_mult lookup_monom_mult_plus)
qed
qed
corollary lc_map_scale [simp]: "lc (c ⋅ p) = (c::'b::semiring_no_zero_divisors) * lc p"
by (simp add: map_scale_eq_monom_mult)
lemma (in ordered_term) lt_mult_scalar_monomial_right:
assumes "c ≠ (0::'b::semiring_no_zero_divisors)" and "p ≠ 0"
shows "lt (p ⊙ monomial c v) = punit.lt p ⊕ v"
proof (intro lt_eqI)
from assms(1) show "lookup (p ⊙ monomial c v) (punit.lt p ⊕ v) ≠ 0"
proof (simp add: lookup_mult_scalar_monomial_right_plus)
from assms(2) show "lookup p (punit.lt p) ≠ 0"
using in_keys_iff punit.lt_in_keys by fastforce
qed
next
fix u::'t
assume "lookup (p ⊙ monomial c v) u ≠ 0"
hence "u ∈ keys (p ⊙ monomial c v)" by (simp add: in_keys_iff)
also have "... ⊆ (λt. t ⊕ v) ` keys p" by (fact keys_mult_scalar_monomial_right_subset)
finally obtain t where "t ∈ keys p" and "u = t ⊕ v" ..
show "u ≼⇩t punit.lt p ⊕ v" unfolding ‹u = t ⊕ v›
proof (rule splus_mono_left)
from ‹t ∈ keys p› show "t ≼ punit.lt p" by (rule punit.lt_max_keys)
qed
qed
lemma lc_mult_scalar_monomial_right:
"lc (p ⊙ monomial c v) = punit.lc p * (c::'b::semiring_no_zero_divisors)"
proof (cases "c = 0")
case True
thus ?thesis by simp
next
case False
show ?thesis
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
with ‹c ≠ 0› show ?thesis
by (simp add: punit.lc_def lc_def lt_mult_scalar_monomial_right lookup_mult_scalar_monomial_right_plus)
qed
qed
lemma lookup_monom_mult_eq_zero:
assumes "s ⊕ lt p ≺⇩t v"
shows "lookup (monom_mult (c::'b::semiring_no_zero_divisors) s p) v = 0"
by (metis assms aux lt_gr lt_monom_mult monom_mult_zero_left monom_mult_zero_right
ord_term_lin.order.strict_implies_not_eq)
lemma in_keys_monom_mult_le:
assumes "v ∈ keys (monom_mult c t p)"
shows "v ≼⇩t t ⊕ lt p"
proof -
from keys_monom_mult_subset assms have "v ∈ (⊕) t ` (keys p)" ..
then obtain u where "u ∈ keys p" and "v = t ⊕ u" ..
from ‹u ∈ keys p› have "u ≼⇩t lt p" by (rule lt_max_keys)
thus "v ≼⇩t t ⊕ lt p" unfolding ‹v = t ⊕ u› by (rule splus_mono)
qed
lemma lt_monom_mult_le: "lt (monom_mult c t p) ≼⇩t t ⊕ lt p"
by (metis aux in_keys_monom_mult_le lt_in_keys lt_le_iff)
lemma monom_mult_inj_2:
assumes "monom_mult c t1 p = monom_mult c t2 p"
and "c ≠ 0" and "(p::'t ⇒⇩0 'b::semiring_no_zero_divisors) ≠ 0"
shows "t1 = t2"
proof -
from assms(1) have "lt (monom_mult c t1 p) = lt (monom_mult c t2 p)" by simp
with ‹c ≠ 0› ‹p ≠ 0› have "t1 ⊕ lt p = t2 ⊕ lt p" by (simp add: lt_monom_mult)
thus ?thesis by (simp add: term_simps)
qed
subsection ‹Trailing Term and Trailing Coefficient: @{const tt} and @{const tc}›
lemma tt_zero [simp]: "tt 0 = min_term"
by (simp add: tt_def)
lemma tc_zero [simp]: "tc 0 = 0"
by (simp add: tc_def)
lemma tt_alt:
assumes "p ≠ 0"
shows "tt p = ord_term_lin.Min (keys p)"
using assms unfolding tt_def by simp
lemma tt_min_keys:
assumes "v ∈ keys p"
shows "tt p ≼⇩t v"
proof -
from assms have "keys p ≠ {}" by auto
hence "p ≠ 0" by simp
from tt_alt[OF this] ord_term_lin.Min_le[OF finite_keys assms] show ?thesis by simp
qed
lemma tt_min:
assumes "lookup p v ≠ 0"
shows "tt p ≼⇩t v"
proof -
from assms have "v ∈ keys p" unfolding keys_def by simp
thus ?thesis by (rule tt_min_keys)
qed
lemma tt_in_keys:
assumes "p ≠ 0"
shows "tt p ∈ keys p"
unfolding tt_alt[OF assms]
by (rule ord_term_lin.Min_in, fact finite_keys, simp add: assms)
lemma tt_eqI:
assumes "v ∈ keys p" and "⋀u. u ∈ keys p ⟹ v ≼⇩t u"
shows "tt p = v"
proof -
from assms(1) have "keys p ≠ {}" by auto
hence "p ≠ 0" by simp
from assms(1) have "tt p ≼⇩t v" by (rule tt_min_keys)
moreover have "v ≼⇩t tt p" by (rule assms(2), rule tt_in_keys, fact ‹p ≠ 0›)
ultimately show ?thesis by simp
qed
lemma tt_gr:
assumes "⋀u. u ∈ keys p ⟹ v ≺⇩t u" and "p ≠ 0"
shows "v ≺⇩t tt p"
proof -
from ‹p ≠ 0› have "keys p ≠ {}" by simp
show ?thesis by (rule assms(1), rule tt_in_keys, fact ‹p ≠ 0›)
qed
lemma tt_less:
assumes "u ∈ keys p" and "u ≺⇩t v"
shows "tt p ≺⇩t v"
proof -
from ‹u ∈ keys p› have "tt p ≼⇩t u" by (rule tt_min_keys)
also have "... ≺⇩t v" by fact
finally show "tt p ≺⇩t v" .
qed
lemma tt_ge:
assumes "⋀u. u ≺⇩t v ⟹ lookup p u = 0" and "p ≠ 0"
shows "v ≼⇩t tt p"
proof -
from ‹p ≠ 0› have "keys p ≠ {}" by simp
have "∀u∈keys p. v ≼⇩t u"
proof
fix u::'t
assume "u ∈ keys p"
hence "lookup p u ≠ 0" unfolding keys_def by simp
hence "¬ u ≺⇩t v" using assms(1)[of u] by auto
thus "v ≼⇩t u" by simp
qed
with tt_alt[OF ‹p ≠ 0›] ord_term_lin.Min_ge_iff[OF finite_keys[of p] ‹keys p ≠ {}›]
show ?thesis by simp
qed
lemma tt_ge_keys:
assumes "⋀u. u ∈ keys p ⟹ v ≼⇩t u" and "p ≠ 0"
shows "v ≼⇩t tt p"
by (rule assms(1), rule tt_in_keys, fact)
lemma tt_ge_iff: "v ≼⇩t tt p ⟷ ((p ≠ 0 ∨ v = min_term) ∧ (∀u. u ≺⇩t v ⟶ lookup p u = 0))"
(is "?L ⟷ (?A ∧ ?B)")
proof
assume ?L
show "?A ∧ ?B"
proof (intro conjI allI impI)
show "p ≠ 0 ∨ v = min_term"
proof (cases "p = 0")
case True
show ?thesis
proof (rule disjI2)
from ‹?L› True have "v ≼⇩t min_term" by (simp add: tt_def)
with min_term_min[of v] show "v = min_term" by simp
qed
next
case False
thus ?thesis ..
qed
next
fix u
assume "u ≺⇩t v"
also note ‹v ≼⇩t tt p›
finally have "u ≺⇩t tt p" .
hence "¬ tt p ≼⇩t u" by simp
with tt_min[of p u] show "lookup p u = 0" by blast
qed
next
assume "?A ∧ ?B"
hence ?A and ?B by simp_all
show ?L
proof (cases "p = 0")
case True
with ‹?A› have "v = min_term" by simp
with True show ?thesis by (simp add: tt_def)
next
case False
from ‹?B› show ?thesis using tt_ge[OF _ False] by auto
qed
qed
lemma tc_not_0:
assumes "p ≠ 0"
shows "tc p ≠ 0"
unfolding tc_def in_keys_iff[symmetric] using assms by (rule tt_in_keys)
lemma tt_monomial:
assumes "c ≠ 0"
shows "tt (monomial c v) = v"
proof (rule tt_eqI)
from keys_of_monomial[OF assms, of v] show "v ∈ keys (monomial c v)" by simp
next
fix u
assume "u ∈ keys (monomial c v)"
with keys_of_monomial[OF assms, of v] have "u = v" by simp
thus "v ≼⇩t u" by simp
qed
lemma tc_monomial [simp]: "tc (monomial c t) = c"
proof (cases "c = 0")
case True
thus ?thesis by simp
next
case False
thus ?thesis by (simp add: tc_def tt_monomial)
qed
lemma tt_plus_eqI:
assumes "p ≠ 0" and "tt p ≺⇩t tt q"
shows "tt (p + q) = tt p"
proof (intro tt_eqI)
from tt_less[of "tt p" q "tt q"] ‹tt p ≺⇩t tt q› have "tt p ∉ keys q" by blast
with lookup_add[of p q "tt p"] tc_not_0[OF ‹p ≠ 0›] show "tt p ∈ keys (p + q)"
unfolding in_keys_iff tc_def by simp
next
fix u
assume "u ∈ keys (p + q)"
show "tt p ≼⇩t u"
proof (rule ccontr)
assume "¬ tt p ≼⇩t u"
hence sp: "u ≺⇩t tt p" by simp
hence "u ≺⇩t tt q" using ‹tt p ≺⇩t tt q› by simp
with tt_less[of u q "tt q"] have "u ∉ keys q" by blast
moreover from sp tt_less[of u p "tt p"] have "u ∉ keys p" by blast
ultimately show False using ‹u ∈ keys (p + q)› Poly_Mapping.keys_add[of p q] by auto
qed
qed
lemma tt_plus_lessE:
fixes p q
assumes "p + q ≠ 0" and tt: "tt (p + q) ≺⇩t tt p"
shows "tt q ≺⇩t tt p"
proof (cases "p = 0")
case True
with tt show ?thesis by simp
next
case False
show ?thesis
proof (rule ccontr)
assume "¬ tt q ≺⇩t tt p"
hence "tt p = tt q ∨ tt p ≺⇩t tt q" by auto
thus False
proof
assume tt_eq: "tt p = tt q"
have "tt p ≼⇩t tt (p + q)"
proof (rule tt_ge_keys)
fix u
assume "u ∈ keys (p + q)"
hence "u ∈ keys p ∪ keys q"
proof
show "keys (p + q) ⊆ keys p ∪ keys q" by (fact Poly_Mapping.keys_add)
qed
thus "tt p ≼⇩t u"
proof
assume "u ∈ keys p"
thus ?thesis by (rule tt_min_keys)
next
assume "u ∈ keys q"
thus ?thesis unfolding tt_eq by (rule tt_min_keys)
qed
qed (fact ‹p + q ≠ 0›)
with tt show False by simp
next
assume "tt p ≺⇩t tt q"
from tt_plus_eqI[OF False this] tt show False by (simp add: ac_simps)
qed
qed
qed
lemma tt_plus_lessI:
fixes p q :: "_ ⇒⇩0 'b::ring"
assumes "p + q ≠ 0" and tt_eq: "tt q = tt p" and tc_eq: "tc q = - tc p"
shows "tt p ≺⇩t tt (p + q)"
proof (rule ccontr)
assume "¬ tt p ≺⇩t tt (p + q)"
hence "tt p = tt (p + q) ∨ tt (p + q) ≺⇩t tt p" by auto
thus False
proof
assume "tt p = tt (p + q)"
have "lookup (p + q) (tt p) = (lookup p (tt p)) + (lookup q (tt q))" unfolding tt_eq lookup_add ..
also have "... = tc p + tc q" unfolding tc_def ..
also have "... = 0" unfolding tc_eq by simp
finally have "lookup (p + q) (tt p) = 0" .
hence "tt (p + q) ≠ tt p" using tc_not_0[OF ‹p + q ≠ 0›] unfolding tc_def by auto
with ‹tt p = tt (p + q)› show False by simp
next
assume "tt (p + q) ≺⇩t tt p"
have "tt q ≺⇩t tt p" by (rule tt_plus_lessE, fact+)
hence "tt q ≠ tt p" by simp
with tt_eq show False by simp
qed
qed
lemma tt_uminus [simp]: "tt (- p) = tt p"
by (simp add: tt_def keys_uminus)
lemma tc_uminus [simp]: "tc (- p) = - tc p"
by (simp add: tc_def)
lemma tt_monom_mult:
assumes "c ≠ (0::'b::semiring_no_zero_divisors)" and "p ≠ 0"
shows "tt (monom_mult c t p) = t ⊕ tt p"
proof (intro tt_eqI, rule keys_monom_multI, rule tt_in_keys, fact, fact)
fix u
assume "u ∈ keys (monom_mult c t p)"
then obtain v where "v ∈ keys p" and u: "u = t ⊕ v" by (rule keys_monom_multE)
show "t ⊕ tt p ≼⇩t u" unfolding u add.commute[of t] by (rule splus_mono, rule tt_min_keys, fact)
qed
lemma tt_map_scale: "c ≠ (0::'b::semiring_no_zero_divisors) ⟹ tt (c ⋅ p) = tt p"
by (cases "p = 0") (simp_all add: map_scale_eq_monom_mult tt_monom_mult term_simps)
lemma tc_monom_mult [simp]: "tc (monom_mult c t p) = (c::'b::semiring_no_zero_divisors) * tc p"
proof (cases "c = 0")
case True
thus ?thesis by simp
next
case False
show ?thesis
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
with ‹c ≠ 0› show ?thesis by (simp add: tc_def tt_monom_mult lookup_monom_mult_plus)
qed
qed
corollary tc_map_scale [simp]: "tc (c ⋅ p) = (c::'b::semiring_no_zero_divisors) * tc p"
by (simp add: map_scale_eq_monom_mult)
lemma in_keys_monom_mult_ge:
assumes "v ∈ keys (monom_mult c t p)"
shows "t ⊕ tt p ≼⇩t v"
proof -
from keys_monom_mult_subset assms have "v ∈ (⊕) t ` (keys p)" ..
then obtain u where "u ∈ keys p" and "v = t ⊕ u" ..
from ‹u ∈ keys p› have "tt p ≼⇩t u" by (rule tt_min_keys)
thus "t ⊕ tt p ≼⇩t v" unfolding ‹v = t ⊕ u› by (rule splus_mono)
qed
lemma lt_ge_tt: "tt p ≼⇩t lt p"
proof (cases "p = 0")
case True
show ?thesis unfolding True lt_def tt_def by simp
next
case False
show ?thesis by (rule lt_max_keys, rule tt_in_keys, fact False)
qed
lemma lt_eq_tt_monomial:
assumes "is_monomial p"
shows "lt p = tt p"
proof -
from assms obtain c v where "c ≠ 0" and p: "p = monomial c v" by (rule is_monomial_monomial)
from ‹c ≠ 0› have "lt p = v" and "tt p = v" unfolding p by (rule lt_monomial, rule tt_monomial)
thus ?thesis by simp
qed
subsection ‹@{const higher} and @{const lower}›
lemma lookup_higher: "lookup (higher p u) v = (if u ≺⇩t v then lookup p v else 0)"
by (auto simp add: higher_def lookup_except)
lemma lookup_higher_when: "lookup (higher p u) v = (lookup p v when u ≺⇩t v)"
by (auto simp add: lookup_higher when_def)
lemma higher_plus: "higher (p + q) v = higher p v + higher q v"
by (rule poly_mapping_eqI, simp add: lookup_add lookup_higher)
lemma higher_uminus [simp]: "higher (- p) v = -(higher p v)"
by (rule poly_mapping_eqI, simp add: lookup_higher)
lemma higher_minus: "higher (p - q) v = higher p v - higher q v"
by (auto intro!: poly_mapping_eqI simp: lookup_minus lookup_higher)
lemma higher_zero [simp]: "higher 0 t = 0"
by (rule poly_mapping_eqI, simp add: lookup_higher)
lemma higher_eq_iff: "higher p v = higher q v ⟷ (∀u. v ≺⇩t u ⟶ lookup p u = lookup q u)" (is "?L ⟷ ?R")
proof
assume ?L
show ?R
proof (intro allI impI)
fix u
assume "v ≺⇩t u"
moreover from ‹?L› have "lookup (higher p v) u = lookup (higher q v) u" by simp
ultimately show "lookup p u = lookup q u" by (simp add: lookup_higher)
qed
next
assume ?R
show ?L
proof (rule poly_mapping_eqI, simp add: lookup_higher, rule)
fix u
assume "v ≺⇩t u"
with ‹?R› show "lookup p u = lookup q u" by simp
qed
qed
lemma higher_eq_zero_iff: "higher p v = 0 ⟷ (∀u. v ≺⇩t u ⟶ lookup p u = 0)"
proof -
have "higher p v = higher 0 v ⟷ (∀u. v ≺⇩t u ⟶ lookup p u = lookup 0 u)" by (rule higher_eq_iff)
thus ?thesis by simp
qed
lemma keys_higher: "keys (higher p v) = {u∈keys p. v ≺⇩t u}"
by (rule set_eqI, simp only: in_keys_iff, simp add: lookup_higher)
lemma higher_higher: "higher (higher p u) v = higher p (ord_term_lin.max u v)"
by (rule poly_mapping_eqI, simp add: lookup_higher)
lemma lookup_lower: "lookup (lower p u) v = (if v ≺⇩t u then lookup p v else 0)"
by (auto simp add: lower_def lookup_except)
lemma lookup_lower_when: "lookup (lower p u) v = (lookup p v when v ≺⇩t u)"
by (auto simp add: lookup_lower when_def)
lemma lower_plus: "lower (p + q) v = lower p v + lower q v"
by (rule poly_mapping_eqI, simp add: lookup_add lookup_lower)
lemma lower_uminus [simp]: "lower (- p) v = - lower p v"
by (rule poly_mapping_eqI, simp add: lookup_lower)
lemma lower_minus: "lower (p - (q::_ ⇒⇩0 'b::ab_group_add)) v = lower p v - lower q v"
by (auto intro!: poly_mapping_eqI simp: lookup_minus lookup_lower)
lemma lower_zero [simp]: "lower 0 v = 0"
by (rule poly_mapping_eqI, simp add: lookup_lower)
lemma lower_eq_iff: "lower p v = lower q v ⟷ (∀u. u ≺⇩t v ⟶ lookup p u = lookup q u)" (is "?L ⟷ ?R")
proof
assume ?L
show ?R
proof (intro allI impI)
fix u
assume "u ≺⇩t v"
moreover from ‹?L› have "lookup (lower p v) u = lookup (lower q v) u" by simp
ultimately show "lookup p u = lookup q u" by (simp add: lookup_lower)
qed
next
assume ?R
show ?L
proof (rule poly_mapping_eqI, simp add: lookup_lower, rule)
fix u
assume "u ≺⇩t v"
with ‹?R› show "lookup p u = lookup q u" by simp
qed
qed
lemma lower_eq_zero_iff: "lower p v = 0 ⟷ (∀u. u ≺⇩t v ⟶ lookup p u = 0)"
proof -
have "lower p v = lower 0 v ⟷ (∀u. u ≺⇩t v ⟶ lookup p u = lookup 0 u)" by (rule lower_eq_iff)
thus ?thesis by simp
qed
lemma keys_lower: "keys (lower p v) = {u∈keys p. u ≺⇩t v}"
by (rule set_eqI, simp only: in_keys_iff, simp add: lookup_lower)
lemma lower_lower: "lower (lower p u) v = lower p (ord_term_lin.min u v)"
by (rule poly_mapping_eqI, simp add: lookup_lower)
lemma lt_higher:
assumes "v ≺⇩t lt p"
shows "lt (higher p v) = lt p"
proof (rule lt_eqI_keys, simp_all add: keys_higher, rule conjI, rule lt_in_keys, rule)
assume "p = 0"
hence "lt p = min_term" by (simp add: lt_def)
with min_term_min[of v] assms show False by simp
next
fix u
assume "u ∈ keys p ∧ v ≺⇩t u"
hence "u ∈ keys p" ..
thus "u ≼⇩t lt p" by (rule lt_max_keys)
qed fact
lemma lc_higher:
assumes "v ≺⇩t lt p"
shows "lc (higher p v) = lc p"
by (simp add: lc_def lt_higher assms lookup_higher)
lemma higher_eq_zero_iff': "higher p v = 0 ⟷ lt p ≼⇩t v"
by (simp add: higher_eq_zero_iff lt_le_iff)
lemma higher_id_iff: "higher p v = p ⟷ (p = 0 ∨ v ≺⇩t tt p)" (is "?L ⟷ ?R")
proof
assume ?L
show ?R
proof (cases "p = 0")
case True
thus ?thesis ..
next
case False
show ?thesis
proof (rule disjI2, rule tt_gr)
fix u
assume "u ∈ keys p"
hence "lookup p u ≠ 0" by (simp add: in_keys_iff)
from ‹?L› have "lookup (higher p v) u = lookup p u" by simp
hence "lookup p u = (if v ≺⇩t u then lookup p u else 0)" by (simp only: lookup_higher)
hence "¬ v ≺⇩t u ⟹ lookup p u = 0" by simp
with ‹lookup p u ≠ 0› show "v ≺⇩t u" by auto
qed fact
qed
next
assume ?R
show ?L
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
with ‹?R› have "v ≺⇩t tt p" by simp
show ?thesis
proof (rule poly_mapping_eqI, simp add: lookup_higher, intro impI)
fix u
assume "¬ v ≺⇩t u"
hence "u ≼⇩t v" by simp
from this ‹v ≺⇩t tt p› have "u ≺⇩t tt p" by simp
hence "¬ tt p ≼⇩t u" by simp
with tt_min[of p u] show "lookup p u = 0" by blast
qed
qed
qed
lemma tt_lower:
assumes "tt p ≺⇩t v"
shows "tt (lower p v) = tt p"
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
show ?thesis
proof (rule tt_eqI, simp_all add: keys_lower, rule, rule tt_in_keys)
fix u
assume "u ∈ keys p ∧ u ≺⇩t v"
hence "u ∈ keys p" ..
thus "tt p ≼⇩t u" by (rule tt_min_keys)
qed fact+
qed
lemma tc_lower:
assumes "tt p ≺⇩t v"
shows "tc (lower p v) = tc p"
by (simp add: tc_def tt_lower assms lookup_lower)
lemma lt_lower: "lt (lower p v) ≼⇩t lt p"
proof (cases "lower p v = 0")
case True
thus ?thesis by (simp add: lt_def min_term_min)
next
case False
show ?thesis
proof (rule lt_le, simp add: lookup_lower, rule impI, rule ccontr)
fix u
assume "lookup p u ≠ 0"
hence "u ≼⇩t lt p" by (rule lt_max)
moreover assume "lt p ≺⇩t u"
ultimately show False by simp
qed
qed
lemma lt_lower_less:
assumes "lower p v ≠ 0"
shows "lt (lower p v) ≺⇩t v"
using assms
proof (rule lt_less)
fix u
assume "v ≼⇩t u"
thus "lookup (lower p v) u = 0" by (simp add: lookup_lower_when)
qed
lemma lt_lower_eq_iff: "lt (lower p v) = lt p ⟷ (lt p = min_term ∨ lt p ≺⇩t v)" (is "?L ⟷ ?R")
proof
assume ?L
show ?R
proof (rule ccontr, simp, elim conjE)
assume "lt p ≠ min_term"
hence "min_term ≺⇩t lt p" using min_term_min ord_term_lin.dual_order.not_eq_order_implies_strict
by blast
assume "¬ lt p ≺⇩t v"
hence "v ≼⇩t lt p" by simp
have "lt (lower p v) ≺⇩t lt p"
proof (cases "lower p v = 0")
case True
thus ?thesis using ‹min_term ≺⇩t lt p› by (simp add: lt_def)
next
case False
show ?thesis
proof (rule lt_less)
fix u
assume "lt p ≼⇩t u"
with ‹v ≼⇩t lt p› have "¬ u ≺⇩t v" by simp
thus "lookup (lower p v) u = 0" by (simp add: lookup_lower)
qed fact
qed
with ‹?L› show False by simp
qed
next
assume ?R
show ?L
proof (cases "lt p = min_term")
case True
hence "lt p ≼⇩t lt (lower p v)" by (simp add: min_term_min)
with lt_lower[of p v] show ?thesis by simp
next
case False
with ‹?R› have "lt p ≺⇩t v" by simp
show ?thesis
proof (rule lt_eqI_keys, simp_all add: keys_lower, rule conjI, rule lt_in_keys, rule)
assume "p = 0"
hence "lt p = min_term" by (simp add: lt_def)
with False show False ..
next
fix u
assume "u ∈ keys p ∧ u ≺⇩t v"
hence "u ∈ keys p" ..
thus "u ≼⇩t lt p" by (rule lt_max_keys)
qed fact
qed
qed
lemma tt_higher:
assumes "v ≺⇩t lt p"
shows "tt p ≼⇩t tt (higher p v)"
proof (rule tt_ge_keys, simp add: keys_higher)
fix u
assume "u ∈ keys p ∧ v ≺⇩t u"
hence "u ∈ keys p" ..
thus "tt p ≼⇩t u" by (rule tt_min_keys)
next
show "higher p v ≠ 0"
proof (simp add: higher_eq_zero_iff, intro exI conjI)
have "p ≠ 0"
proof
assume "p = 0"
hence "lt p ≼⇩t v" by (simp add: lt_def min_term_min)
with assms show False by simp
qed
thus "lookup p (lt p) ≠ 0"
using lt_in_keys by auto
qed fact
qed
lemma tt_higher_eq_iff:
"tt (higher p v) = tt p ⟷ ((lt p ≼⇩t v ∧ tt p = min_term) ∨ v ≺⇩t tt p)" (is "?L ⟷ ?R")
proof
assume ?L
show ?R
proof (rule ccontr, simp, elim conjE)
assume a: "lt p ≼⇩t v ⟶ tt p ≠ min_term"
assume "¬ v ≺⇩t tt p"
hence "tt p ≼⇩t v" by simp
have "tt p ≺⇩t tt (higher p v)"
proof (cases "higher p v = 0")
case True
with ‹?L› have "tt p = min_term" by (simp add: tt_def)
with a have "v ≺⇩t lt p" by auto
have "lt p ≠ min_term"
proof
assume "lt p = min_term"
with ‹v ≺⇩t lt p› show False using min_term_min[of v] by auto
qed
hence "p ≠ 0" by (auto simp add: lt_def)
from ‹v ≺⇩t lt p› have "higher p v ≠ 0" by (simp add: higher_eq_zero_iff')
from this True show ?thesis ..
next
case False
show ?thesis
proof (rule tt_gr)
fix u
assume "u ∈ keys (higher p v)"
hence "v ≺⇩t u" by (simp add: keys_higher)
with ‹tt p ≼⇩t v› show "tt p ≺⇩t u" by simp
qed fact
qed
with ‹?L› show False by simp
qed
next
assume ?R
show ?L
proof (cases "lt p ≼⇩t v ∧ tt p = min_term")
case True
hence "lt p ≼⇩t v" and "tt p = min_term" by simp_all
from ‹lt p ≼⇩t v› have "higher p v = 0" by (simp add: higher_eq_zero_iff')
with ‹tt p = min_term› show ?thesis by (simp add: tt_def)
next
case False
with ‹?R› have "v ≺⇩t tt p" by simp
show ?thesis
proof (rule tt_eqI, simp_all add: keys_higher, rule conjI, rule tt_in_keys, rule)
assume "p = 0"
hence "tt p = min_term" by (simp add: tt_def)
with ‹v ≺⇩t tt p› min_term_min[of v] show False by simp
next
fix u
assume "u ∈ keys p ∧ v ≺⇩t u"
hence "u ∈ keys p" ..
thus "tt p ≼⇩t u" by (rule tt_min_keys)
qed fact
qed
qed
lemma lower_eq_zero_iff': "lower p v = 0 ⟷ (p = 0 ∨ v ≼⇩t tt p)"
by (auto simp add: lower_eq_zero_iff tt_ge_iff)
lemma lower_id_iff: "lower p v = p ⟷ (p = 0 ∨ lt p ≺⇩t v)" (is "?L ⟷ ?R")
proof
assume ?L
show ?R
proof (cases "p = 0")
case True
thus ?thesis ..
next
case False
show ?thesis
proof (rule disjI2, rule lt_less)
fix u
assume "v ≼⇩t u"
from ‹?L› have "lookup (lower p v) u = lookup p u" by simp
hence "lookup p u = (if u ≺⇩t v then lookup p u else 0)" by (simp only: lookup_lower)
hence "v ≼⇩t u ⟹ lookup p u = 0" by (meson ord_term_lin.leD)
with ‹v ≼⇩t u› show "lookup p u = 0" by simp
qed fact
qed
next
assume ?R
show ?L
proof (cases "p = 0", simp)
case False
with ‹?R› have "lt p ≺⇩t v" by simp
show ?thesis
proof (rule poly_mapping_eqI, simp add: lookup_lower, intro impI)
fix u
assume "¬ u ≺⇩t v"
hence "v ≼⇩t u" by simp
with ‹lt p ≺⇩t v› have "lt p ≺⇩t u" by simp
hence "¬ u ≼⇩t lt p" by simp
with lt_max[of p u] show "lookup p u = 0" by blast
qed
qed
qed
lemma lower_higher_commute: "higher (lower p s) t = lower (higher p t) s"
by (rule poly_mapping_eqI, simp add: lookup_higher lookup_lower)
lemma lt_lower_higher:
assumes "v ≺⇩t lt (lower p u)"
shows "lt (lower (higher p v) u) = lt (lower p u)"
by (simp add: lower_higher_commute[symmetric] lt_higher[OF assms])
lemma lc_lower_higher:
assumes "v ≺⇩t lt (lower p u)"
shows "lc (lower (higher p v) u) = lc (lower p u)"
using assms by (simp add: lc_def lt_lower_higher lookup_lower lookup_higher)
lemma trailing_monomial_higher:
assumes "p ≠ 0"
shows "p = (higher p (tt p)) + monomial (tc p) (tt p)"
proof (rule poly_mapping_eqI, simp only: lookup_add)
fix v
show "lookup p v = lookup (higher p (tt p)) v + lookup (monomial (tc p) (tt p)) v"
proof (cases "tt p ≼⇩t v")
case True
show ?thesis
proof (cases "v = tt p")
assume "v = tt p"
hence "¬ tt p ≺⇩t v" by simp
hence "lookup (higher p (tt p)) v = 0" by (simp add: lookup_higher)
moreover from ‹v = tt p› have "lookup (monomial (tc p) (tt p)) v = tc p" by (simp add: lookup_single)
moreover from ‹v = tt p› have "lookup p v = tc p" by (simp add: tc_def)
ultimately show ?thesis by simp
next
assume "v ≠ tt p"
from this True have "tt p ≺⇩t v" by simp
hence "lookup (higher p (tt p)) v = lookup p v" by (simp add: lookup_higher)
moreover from ‹v ≠ tt p› have "lookup (monomial (tc p) (tt p)) v = 0" by (simp add: lookup_single)
ultimately show ?thesis by simp
qed
next
case False
hence "v ≺⇩t tt p" by simp
hence "tt p ≠ v" by simp
from False have "¬ tt p ≺⇩t v" by simp
have "lookup p v = 0"
proof (rule ccontr)
assume "lookup p v ≠ 0"
from tt_min[OF this] False show False by simp
qed
moreover from ‹tt p ≠ v› have "lookup (monomial (tc p) (tt p)) v = 0" by (simp add: lookup_single)
moreover from ‹¬ tt p ≺⇩t v› have "lookup (higher p (tt p)) v = 0" by (simp add: lookup_higher)
ultimately show ?thesis by simp
qed
qed
lemma higher_lower_decomp: "higher p v + monomial (lookup p v) v + lower p v = p"
proof (rule poly_mapping_eqI)
fix u
show "lookup (higher p v + monomial (lookup p v) v + lower p v) u = lookup p u"
proof (rule ord_term_lin.linorder_cases)
assume "u ≺⇩t v"
thus ?thesis by (simp add: lookup_add lookup_higher_when lookup_single lookup_lower_when)
next
assume "u = v"
thus ?thesis by (simp add: lookup_add lookup_higher_when lookup_single lookup_lower_when)
next
assume "v ≺⇩t u"
thus ?thesis by (simp add: lookup_add lookup_higher_when lookup_single lookup_lower_when)
qed
qed
subsection ‹@{const tail}›
lemma lookup_tail: "lookup (tail p) v = (if v ≺⇩t lt p then lookup p v else 0)"
by (simp add: lookup_lower tail_def)
lemma lookup_tail_when: "lookup (tail p) v = (lookup p v when v ≺⇩t lt p)"
by (simp add: lookup_lower_when tail_def)
lemma lookup_tail_2: "lookup (tail p) v = (if v = lt p then 0 else lookup p v)"
proof (rule ord_term_lin.linorder_cases[of v "lt p"])
assume "v ≺⇩t lt p"
hence "v ≠ lt p" by simp
from this ‹v ≺⇩t lt p› lookup_tail[of p v] show ?thesis by simp
next
assume "v = lt p"
hence "¬ v ≺⇩t lt p" by simp
from ‹v = lt p› this lookup_tail[of p v] show ?thesis by simp
next
assume "lt p ≺⇩t v"
hence "¬ v ≼⇩t lt p" by simp
hence cp: "lookup p v = 0"
using lt_max by blast
from ‹¬ v ≼⇩t lt p› have "¬ v = lt p" and "¬ v ≺⇩t lt p" by simp_all
thus ?thesis using cp lookup_tail[of p v] by simp
qed
lemma leading_monomial_tail: "p = monomial (lc p) (lt p) + tail p" for p::"_ ⇒⇩0 'b::comm_monoid_add"
proof (rule poly_mapping_eqI)
fix v
have "lookup p v = lookup (monomial (lc p) (lt p)) v + lookup (tail p) v"
proof (cases "v ≼⇩t lt p")
case True
show ?thesis
proof (cases "v = lt p")
assume "v = lt p"
hence "¬ v ≺⇩t lt p" by simp
hence c3: "lookup (tail p) v = 0" unfolding lookup_tail[of p v] by simp
from ‹v = lt p› have c2: "lookup (monomial (lc p) (lt p)) v = lc p" by simp
from ‹v = lt p› have c1: "lookup p v = lc p" by (simp add: lc_def)
from c1 c2 c3 show ?thesis by simp
next
assume "v ≠ lt p"
from this True have "v ≺⇩t lt p" by simp
hence c2: "lookup (tail p) v = lookup p v" unfolding lookup_tail[of p v] by simp
from ‹v ≠ lt p› have c1: "lookup (monomial (lc p) (lt p)) v = 0" by (simp add: lookup_single)
from c1 c2 show ?thesis by simp
qed
next
case False
hence "lt p ≺⇩t v" by simp
hence "lt p ≠ v" by simp
from False have "¬ v ≺⇩t lt p" by simp
have c1: "lookup p v = 0"
proof (rule ccontr)
assume "lookup p v ≠ 0"
from lt_max[OF this] False show False by simp
qed
from ‹lt p ≠ v› have c2: "lookup (monomial (lc p) (lt p)) v = 0" by (simp add: lookup_single)
from ‹¬ v ≺⇩t lt p› lookup_tail[of p v] have c3: "lookup (tail p) v = 0" by simp
from c1 c2 c3 show ?thesis by simp
qed
thus "lookup p v = lookup (monomial (lc p) (lt p) + tail p) v" by (simp add: lookup_add)
qed
lemma tail_alt: "tail p = except p {lt p}"
by (rule poly_mapping_eqI, simp add: lookup_tail_2 lookup_except)
corollary tail_alt_2: "tail p = p - monomial (lc p) (lt p)"
proof -
have "p = monomial (lc p) (lt p) + tail p" by (fact leading_monomial_tail)
also have "... = tail p + monomial (lc p) (lt p)" by (simp only: add.commute)
finally have "p - monomial (lc p) (lt p) = (tail p + monomial (lc p) (lt p)) - monomial (lc p) (lt p)" by simp
thus ?thesis by simp
qed
lemma tail_zero [simp]: "tail 0 = 0"
by (simp only: tail_alt except_zero)
lemma lt_tail:
assumes "tail p ≠ 0"
shows "lt (tail p) ≺⇩t lt p"
proof (intro lt_less)
fix u
assume "lt p ≼⇩t u"
hence "¬ u ≺⇩t lt p" by simp
thus "lookup (tail p) u = 0" unfolding lookup_tail[of p u] by simp
qed fact
lemma keys_tail: "keys (tail p) = keys p - {lt p}"
by (simp add: tail_alt keys_except)
lemma tail_monomial: "tail (monomial c v) = 0"
by (metis (no_types, lifting) lookup_tail_2 lookup_single_not_eq lt_less lt_monomial
ord_term_lin.dual_order.strict_implies_not_eq single_zero tail_zero)
lemma (in ordered_term) mult_scalar_tail_rec_left:
"p ⊙ q = monom_mult (punit.lc p) (punit.lt p) q + (punit.tail p) ⊙ q"
unfolding punit.lc_def punit.tail_alt by (fact mult_scalar_rec_left)
lemma mult_scalar_tail_rec_right: "p ⊙ q = p ⊙ monomial (lc q) (lt q) + p ⊙ tail q"
unfolding tail_alt lc_def by (rule mult_scalar_rec_right)
lemma lt_tail_max:
assumes "tail p ≠ 0" and "v ∈ keys p" and "v ≺⇩t lt p"
shows "v ≼⇩t lt (tail p)"
proof (rule lt_max_keys, simp add: keys_tail assms(2))
from assms(3) show "v ≠ lt p" by auto
qed
lemma keys_tail_less_lt:
assumes "v ∈ keys (tail p)"
shows "v ≺⇩t lt p"
using assms by (meson in_keys_iff lookup_tail)
lemma tt_tail:
assumes "tail p ≠ 0"
shows "tt (tail p) = tt p"
proof (rule tt_eqI, simp_all add: keys_tail)
from assms have "p ≠ 0" using tail_zero by auto
show "tt p ∈ keys p ∧ tt p ≠ lt p"
proof (rule conjI, rule tt_in_keys, fact)
have "tt p ≺⇩t lt p"
by (metis assms lower_eq_zero_iff' tail_def ord_term_lin.le_less_linear)
thus "tt p ≠ lt p" by simp
qed
next
fix u
assume "u ∈ keys p ∧ u ≠ lt p"
hence "u ∈ keys p" ..
thus "tt p ≼⇩t u" by (rule tt_min_keys)
qed
lemma tc_tail:
assumes "tail p ≠ 0"
shows "tc (tail p) = tc p"
proof (simp add: tc_def tt_tail[OF assms] lookup_tail_2, rule)
assume "tt p = lt p"
moreover have "tt p ≺⇩t lt p"
by (metis assms lower_eq_zero_iff' tail_def ord_term_lin.le_less_linear)
ultimately show "lookup p (lt p) = 0" by simp
qed
lemma tt_tail_min:
assumes "s ∈ keys p"
shows "tt (tail p) ≼⇩t s"
proof (cases "tail p = 0")
case True
hence "tt (tail p) = min_term" by (simp add: tt_def)
thus ?thesis by (simp add: min_term_min)
next
case False
from assms show ?thesis by (simp add: tt_tail[OF False], rule tt_min_keys)
qed
lemma tail_monom_mult:
"tail (monom_mult c t p) = monom_mult (c::'b::semiring_no_zero_divisors) t (tail p)"
proof (cases "p = 0")
case True
hence "tail p = 0" and "monom_mult c t p = 0" by simp_all
thus ?thesis by simp
next
case False
show ?thesis
proof (cases "c = 0")
case True
hence "monom_mult c t p = 0" and "monom_mult c t (tail p) = 0" by simp_all
thus ?thesis by simp
next
case False
let ?a = "monom_mult c t p"
let ?b = "monom_mult c t (tail p)"
from ‹p ≠ 0› False have "?a ≠ 0" by (simp add: monom_mult_eq_zero_iff)
from False ‹p ≠ 0› have lt_a: "lt ?a = t ⊕ lt p" by (rule lt_monom_mult)
show ?thesis
proof (rule poly_mapping_eqI, simp add: lookup_tail lt_a, intro conjI impI)
fix u
assume "u ≺⇩t t ⊕ lt p"
show "lookup (monom_mult c t p) u = lookup (monom_mult c t (tail p)) u"
proof (cases "t adds⇩p u")
case True
then obtain v where "u = t ⊕ v" by (rule adds_ppE)
from ‹u ≺⇩t t ⊕ lt p› have "v ≺⇩t lt p" unfolding ‹u = t ⊕ v› by (rule ord_term_strict_canc)
hence "lookup p v = lookup (tail p) v" by (simp add: lookup_tail)
thus ?thesis by (simp add: ‹u = t ⊕ v› lookup_monom_mult_plus)
next
case False
hence "lookup ?a u = 0" by (simp add: lookup_monom_mult)
moreover have "lookup ?b u = 0"
proof (rule ccontr, simp only: in_keys_iff[symmetric] keys_monom_mult[OF ‹c ≠ 0›])
assume "u ∈ (⊕) t ` keys (tail p)"
then obtain v where "u = t ⊕ v" by auto
hence "t adds⇩p u" by (simp add: term_simps)
with False show False ..
qed
ultimately show ?thesis by simp
qed
next
fix u
assume "¬ u ≺⇩t t ⊕ lt p"
hence "t ⊕ lt p ≼⇩t u" by simp
show "lookup (monom_mult c t (tail p)) u = 0"
proof (rule ccontr, simp only: in_keys_iff[symmetric] keys_monom_mult[OF False])
assume "u ∈ (⊕) t ` keys (tail p)"
then obtain v where "v ∈ keys (tail p)" and "u = t ⊕ v" by auto
from ‹t ⊕ lt p ≼⇩t u› have "lt p ≼⇩t v" unfolding ‹u = t ⊕ v› by (rule ord_term_canc)
from ‹v ∈ keys (tail p)› have "v ∈ keys p" and "v ≠ lt p" by (simp_all add: keys_tail)
from ‹v ∈ keys p› have "v ≼⇩t lt p" by (rule lt_max_keys)
with ‹lt p ≼⇩t v› have "v = lt p " by simp
with ‹v ≠ lt p› show False ..
qed
qed
qed
qed
lemma keys_plus_eq_lt_tt_D:
assumes "keys (p + q) = {lt p, tt q}" and "lt q ≺⇩t lt p" and "tt q ≺⇩t tt (p::_ ⇒⇩0 'b::comm_monoid_add)"
shows "tail p + higher q (tt q) = 0"
proof -
note assms(3)
also have "... ≼⇩t lt p" by (rule lt_ge_tt)
finally have "tt q ≺⇩t lt p" .
hence "lt p ≠ tt q" by simp
have "q ≠ 0"
proof
assume "q = 0"
hence "tt q = min_term" by (simp add: tt_def)
with ‹q = 0› assms(1) have "keys p = {lt p, min_term}" by simp
hence "min_term ∈ keys p" by simp
hence "tt p ≼⇩t tt q" unfolding ‹tt q = min_term› by (rule tt_min_keys)
with assms(3) show False by simp
qed
hence "tc q ≠ 0" by (rule tc_not_0)
have "p = monomial (lc p) (lt p) + tail p" by (rule leading_monomial_tail)
moreover from ‹q ≠ 0› have "q = higher q (tt q) + monomial (tc q) (tt q)" by (rule trailing_monomial_higher)
ultimately have pq: "p + q = (monomial (lc p) (lt p) + monomial (tc q) (tt q)) + (tail p + higher q (tt q))"
(is "_ = (?m1 + ?m2) + ?b") by (simp add: algebra_simps)
have keys_m1: "keys ?m1 = {lt p}"
proof (rule keys_of_monomial, rule lc_not_0, rule)
assume "p = 0"
with assms(2) have "lt q ≺⇩t min_term" by (simp add: lt_def)
with min_term_min[of "lt q"] show False by simp
qed
moreover from ‹tc q ≠ 0› have keys_m2: "keys ?m2 = {tt q}" by (rule keys_of_monomial)
ultimately have keys_m1_m2: "keys (?m1 + ?m2) = {lt p, tt q}"
using ‹lt p ≠ tt q› keys_plus_eqI[of ?m1 ?m2] by auto
show ?thesis
proof (rule ccontr)
assume "?b ≠ 0"
hence "keys ?b ≠ {}" by simp
then obtain t where "t ∈ keys ?b" by blast
hence t_in: "t ∈ keys (tail p) ∪ keys (higher q (tt q))"
using Poly_Mapping.keys_add[of "tail p" "higher q (tt q)"] by blast
hence "t ≠ lt p"
proof (rule, simp add: keys_tail, simp add: keys_higher, elim conjE)
assume "t ∈ keys q"
hence "t ≼⇩t lt q" by (rule lt_max_keys)
from this assms(2) show ?thesis by simp
qed
moreover from t_in have "t ≠ tt q"
proof (rule, simp add: keys_tail, elim conjE)
assume "t ∈ keys p"
hence "tt p ≼⇩t t" by (rule tt_min_keys)
with assms(3) show ?thesis by simp
next
assume "t ∈ keys (higher q (tt q))"
thus ?thesis by (auto simp only: keys_higher)
qed
ultimately have "t ∉ keys (?m1 + ?m2)" by (simp add: keys_m1_m2)
moreover from in_keys_plusI2[OF ‹t ∈ keys ?b› this] have "t ∈ keys (?m1 + ?m2)"
by (simp only: keys_m1_m2 pq[symmetric] assms(1))
ultimately show False ..
qed
qed
subsection ‹Order Relation on Polynomials›
definition ord_strict_p :: "('t ⇒⇩0 'b::zero) ⇒ ('t ⇒⇩0 'b) ⇒ bool" (infixl "≺⇩p" 50) where
"p ≺⇩p q ⟷ (∃v. lookup p v = 0 ∧ lookup q v ≠ 0 ∧ (∀u. v ≺⇩t u ⟶ lookup p u = lookup q u))"
definition ord_p :: "('t ⇒⇩0 'b::zero) ⇒ ('t ⇒⇩0 'b) ⇒ bool" (infixl "≼⇩p" 50) where
"ord_p p q ≡ (p ≺⇩p q ∨ p = q)"
lemma ord_strict_pI:
assumes "lookup p v = 0" and "lookup q v ≠ 0" and "⋀u. v ≺⇩t u ⟹ lookup p u = lookup q u"
shows "p ≺⇩p q"
unfolding ord_strict_p_def using assms by blast
lemma ord_strict_pE:
assumes "p ≺⇩p q"
obtains v where "lookup p v = 0" and "lookup q v ≠ 0" and "⋀u. v ≺⇩t u ⟹ lookup p u = lookup q u"
using assms unfolding ord_strict_p_def by blast
lemma not_ord_pI:
assumes "lookup p v ≠ lookup q v" and "lookup p v ≠ 0" and "⋀u. v ≺⇩t u ⟹ lookup p u = lookup q u"
shows "¬ p ≼⇩p q"
proof
assume "p ≼⇩p q"
hence "p ≺⇩p q ∨ p = q" by (simp only: ord_p_def)
thus False
proof
assume "p ≺⇩p q"
then obtain v' where 1: "lookup p v' = 0" and 2: "lookup q v' ≠ 0"
and 3: "⋀u. v' ≺⇩t u ⟹ lookup p u = lookup q u" by (rule ord_strict_pE, blast)
from 1 2 have "lookup p v' ≠ lookup q v'" by simp
hence "¬ v ≺⇩t v'" using assms(3) by blast
hence "v' ≺⇩t v ∨ v' = v" by auto
thus ?thesis
proof
assume "v' ≺⇩t v"
hence "lookup p v = lookup q v" by (rule 3)
with assms(1) show ?thesis ..
next
assume "v' = v"
with assms(2) 1 show ?thesis by auto
qed
next
assume "p = q"
hence "lookup p v = lookup q v" by simp
with assms(1) show ?thesis ..
qed
qed
corollary not_ord_strict_pI:
assumes "lookup p v ≠ lookup q v" and "lookup p v ≠ 0" and "⋀u. v ≺⇩t u ⟹ lookup p u = lookup q u"
shows "¬ p ≺⇩p q"
proof -
from assms have "¬ p ≼⇩p q" by (rule not_ord_pI)
thus ?thesis by (simp add: ord_p_def)
qed
lemma ord_strict_higher: "p ≺⇩p q ⟷ (∃v. lookup p v = 0 ∧ lookup q v ≠ 0 ∧ higher p v = higher q v)"
unfolding ord_strict_p_def higher_eq_iff ..
lemma ord_strict_p_asymmetric:
assumes "p ≺⇩p q"
shows "¬ q ≺⇩p p"
using assms unfolding ord_strict_p_def
proof
fix v1::'t
assume "lookup p v1 = 0 ∧ lookup q v1 ≠ 0 ∧ (∀u. v1 ≺⇩t u ⟶ lookup p u = lookup q u)"
hence "lookup p v1 = 0" and "lookup q v1 ≠ 0" and v1: "∀u. v1 ≺⇩t u ⟶ lookup p u = lookup q u"
by auto
show "¬ (∃v. lookup q v = 0 ∧ lookup p v ≠ 0 ∧ (∀u. v ≺⇩t u ⟶ lookup q u = lookup p u))"
proof (intro notI, erule exE)
fix v2::'t
assume "lookup q v2 = 0 ∧ lookup p v2 ≠ 0 ∧ (∀u. v2 ≺⇩t u ⟶ lookup q u = lookup p u)"
hence "lookup q v2 = 0" and "lookup p v2 ≠ 0" and v2: "∀u. v2 ≺⇩t u ⟶ lookup q u = lookup p u"
by auto
show False
proof (rule ord_term_lin.linorder_cases)
assume "v1 ≺⇩t v2"
from v1[rule_format, OF this] ‹lookup q v2 = 0› ‹lookup p v2 ≠ 0› show ?thesis by simp
next
assume "v1 = v2"
thus ?thesis using ‹lookup p v1 = 0› ‹lookup p v2 ≠ 0› by simp
next
assume "v2 ≺⇩t v1"
from v2[rule_format, OF this] ‹lookup p v1 = 0› ‹lookup q v1 ≠ 0› show ?thesis by simp
qed
qed
qed
lemma ord_strict_p_irreflexive: "¬ p ≺⇩p p"
unfolding ord_strict_p_def
proof (intro notI, erule exE)
fix v::'t
assume "lookup p v = 0 ∧ lookup p v ≠ 0 ∧ (∀u. v ≺⇩t u ⟶ lookup p u = lookup p u)"
hence "lookup p v = 0" and "lookup p v ≠ 0" by auto
thus False by simp
qed
lemma ord_strict_p_transitive:
assumes "a ≺⇩p b" and "b ≺⇩p c"
shows "a ≺⇩p c"
proof -
from ‹a ≺⇩p b› obtain v1 where "lookup a v1 = 0"
and "lookup b v1 ≠ 0"
and v1[rule_format]: "(∀u. v1 ≺⇩t u ⟶ lookup a u = lookup b u)"
unfolding ord_strict_p_def by auto
from ‹b ≺⇩p c› obtain v2 where "lookup b v2 = 0"
and "lookup c v2 ≠ 0"
and v2[rule_format]: "(∀u. v2 ≺⇩t u ⟶ lookup b u = lookup c u)"
unfolding ord_strict_p_def by auto
show "a ≺⇩p c"
proof (rule ord_term_lin.linorder_cases)
assume "v1 ≺⇩t v2"
show ?thesis unfolding ord_strict_p_def
proof
show "lookup a v2 = 0 ∧ lookup c v2 ≠ 0 ∧ (∀u. v2 ≺⇩t u ⟶ lookup a u = lookup c u)"
proof (intro conjI allI impI)
from ‹lookup b v2 = 0› v1[OF ‹v1 ≺⇩t v2›] show "lookup a v2 = 0" by simp
next
from ‹lookup c v2 ≠ 0› show "lookup c v2 ≠ 0" .
next
fix u
assume "v2 ≺⇩t u"
from ord_term_lin.less_trans[OF ‹v1 ≺⇩t v2› this] have "v1 ≺⇩t u" .
from v2[OF ‹v2 ≺⇩t u›] v1[OF this] show "lookup a u = lookup c u" by simp
qed
qed
next
assume "v2 ≺⇩t v1"
show ?thesis unfolding ord_strict_p_def
proof
show "lookup a v1 = 0 ∧ lookup c v1 ≠ 0 ∧ (∀u. v1 ≺⇩t u ⟶ lookup a u = lookup c u)"
proof (intro conjI allI impI)
from ‹lookup a v1 = 0› show "lookup a v1 = 0" .
next
from ‹lookup b v1 ≠ 0› v2[OF ‹v2 ≺⇩t v1›] show "lookup c v1 ≠ 0" by simp
next
fix u
assume "v1 ≺⇩t u"
from ord_term_lin.less_trans[OF ‹v2 ≺⇩t v1› this] have "v2 ≺⇩t u" .
from v1[OF ‹v1 ≺⇩t u›] v2[OF this] show "lookup a u = lookup c u" by simp
qed
qed
next
assume "v1 = v2"
thus ?thesis using ‹lookup b v1 ≠ 0› ‹lookup b v2 = 0› by simp
qed
qed
sublocale order ord_p ord_strict_p
proof (intro order_strictI)
fix p q :: "'t ⇒⇩0 'b"
show "(p ≼⇩p q) = (p ≺⇩p q ∨ p = q)" unfolding ord_p_def ..
next
fix p q :: "'t ⇒⇩0 'b"
assume "p ≺⇩p q"
thus "¬ q ≺⇩p p" by (rule ord_strict_p_asymmetric)
next
fix p::"'t ⇒⇩0 'b"
show "¬ p ≺⇩p p" by (fact ord_strict_p_irreflexive)
next
fix a b c :: "'t ⇒⇩0 'b"
assume "a ≺⇩p b" and "b ≺⇩p c"
thus "a ≺⇩p c" by (rule ord_strict_p_transitive)
qed
lemma ord_p_zero_min: "0 ≼⇩p p"
unfolding ord_p_def ord_strict_p_def
proof (cases "p = 0")
case True
thus "(∃v. lookup 0 v = 0 ∧ lookup p v ≠ 0 ∧ (∀u. v ≺⇩t u ⟶ lookup 0 u = lookup p u)) ∨ 0 = p"
by auto
next
case False
show "(∃v. lookup 0 v = 0 ∧ lookup p v ≠ 0 ∧ (∀u. v ≺⇩t u ⟶ lookup 0 u = lookup p u)) ∨ 0 = p"
proof
show "(∃v. lookup 0 v = 0 ∧ lookup p v ≠ 0 ∧ (∀u. v ≺⇩t u ⟶ lookup 0 u = lookup p u))"
proof
show "lookup 0 (lt p) = 0 ∧ lookup p (lt p) ≠ 0 ∧ (∀u. (lt p) ≺⇩t u ⟶ lookup 0 u = lookup p u)"
proof (intro conjI allI impI)
show "lookup 0 (lt p) = 0" by (transfer, simp)
next
from lc_not_0[OF False] show "lookup p (lt p) ≠ 0" unfolding lc_def .
next
fix u
assume "lt p ≺⇩t u"
hence "¬ u ≼⇩t lt p" by simp
hence "lookup p u = 0" using lt_max[of p u] by metis
thus "lookup 0 u = lookup p u" by simp
qed
qed
qed
qed
lemma lt_ord_p:
assumes "lt p ≺⇩t lt q"
shows "p ≺⇩p q"
proof -
have "q ≠ 0"
proof
assume "q = 0"
with assms have "lt p ≺⇩t min_term" by (simp add: lt_def)
with min_term_min[of "lt p"] show False by simp
qed
show ?thesis unfolding ord_strict_p_def
proof (intro exI conjI allI impI)
show "lookup p (lt q) = 0"
proof (rule ccontr)
assume "lookup p (lt q) ≠ 0"
from lt_max[OF this] ‹lt p ≺⇩t lt q› show False by simp
qed
next
from lc_not_0[OF ‹q ≠ 0›] show "lookup q (lt q) ≠ 0" unfolding lc_def .
next
fix u
assume "lt q ≺⇩t u"
hence "lt p ≺⇩t u" using ‹lt p ≺⇩t lt q› by simp
have c1: "lookup q u = 0"
proof (rule ccontr)
assume "lookup q u ≠ 0"
from lt_max[OF this] ‹lt q ≺⇩t u› show False by simp
qed
have c2: "lookup p u = 0"
proof (rule ccontr)
assume "lookup p u ≠ 0"
from lt_max[OF this] ‹lt p ≺⇩t u› show False by simp
qed
from c1 c2 show "lookup p u = lookup q u" by simp
qed
qed
lemma ord_p_lt:
assumes "p ≼⇩p q"
shows "lt p ≼⇩t lt q"
proof (rule ccontr)
assume "¬ lt p ≼⇩t lt q"
hence "lt q ≺⇩t lt p" by simp
from lt_ord_p[OF this] ‹p ≼⇩p q› show False by simp
qed
lemma ord_p_tail:
assumes "p ≠ 0" and "lt p = lt q" and "p ≺⇩p q"
shows "tail p ≺⇩p tail q"
using assms unfolding ord_strict_p_def
proof -
assume "p ≠ 0" and "lt p = lt q"
and "∃v. lookup p v = 0 ∧ lookup q v ≠ 0 ∧ (∀u. v ≺⇩t u ⟶ lookup p u = lookup q u)"
then obtain v where "lookup p v = 0"
and "lookup q v ≠ 0"
and a: "∀u. v ≺⇩t u ⟶ lookup p u = lookup q u" by auto
from lt_max[OF ‹lookup q v ≠ 0›] ‹lt p = lt q› have "v ≺⇩t lt p ∨ v = lt p" by auto
hence "v ≺⇩t lt p"
proof
assume "v ≺⇩t lt p"
thus ?thesis .
next
assume "v = lt p"
thus ?thesis using lc_not_0[OF ‹p ≠ 0›] ‹lookup p v = 0› unfolding lc_def by auto
qed
have pt: "lookup (tail p) v = lookup p v" using lookup_tail[of p v] ‹v ≺⇩t lt p› by simp
have "q ≠ 0"
proof
assume "q = 0"
hence "p ≺⇩p 0" using ‹p ≺⇩p q› by simp
hence "¬ 0 ≼⇩p p" by auto
thus False using ord_p_zero_min[of p] by simp
qed
have qt: "lookup (tail q) v = lookup q v"
using lookup_tail[of q v] ‹v ≺⇩t lt p› ‹lt p = lt q› by simp
show "∃w. lookup (tail p) w = 0 ∧ lookup (tail q) w ≠ 0 ∧
(∀u. w ≺⇩t u ⟶ lookup (tail p) u = lookup (tail q) u)"
proof (intro exI conjI allI impI)
from pt ‹lookup p v = 0› show "lookup (tail p) v = 0" by simp
next
from qt ‹lookup q v ≠ 0› show "lookup (tail q) v ≠ 0" by simp
next
fix u
assume "v ≺⇩t u"
from a[rule_format, OF ‹v ≺⇩t u›] lookup_tail[of p u] lookup_tail[of q u]
‹lt p = lt q› show "lookup (tail p) u = lookup (tail q) u" by simp
qed
qed
lemma tail_ord_p:
assumes "p ≠ 0"
shows "tail p ≺⇩p p"
proof (cases "tail p = 0")
case True
with ord_p_zero_min[of p] ‹p ≠ 0› show ?thesis by simp
next
case False
from lt_tail[OF False] show ?thesis by (rule lt_ord_p)
qed
lemma higher_lookup_eq_zero:
assumes pt: "lookup p v = 0" and hp: "higher p v = 0" and le: "q ≼⇩p p"
shows "(lookup q v = 0) ∧ (higher q v) = 0"
using le unfolding ord_p_def
proof
assume "q ≺⇩p p"
thus ?thesis unfolding ord_strict_p_def
proof
fix w
assume "lookup q w = 0 ∧ lookup p w ≠ 0 ∧ (∀u. w ≺⇩t u ⟶ lookup q u = lookup p u)"
hence qs: "lookup q w = 0" and ps: "lookup p w ≠ 0" and u: "∀u. w ≺⇩t u ⟶ lookup q u = lookup p u"
by auto
from hp have pu: "∀u. v ≺⇩t u ⟶ lookup p u = 0" by (simp only: higher_eq_zero_iff)
from pu[rule_format, of w] ps have "¬ v ≺⇩t w" by auto
hence "w ≼⇩t v" by simp
hence "w ≺⇩t v ∨ w = v" by auto
hence st: "w ≺⇩t v"
proof (rule disjE, simp_all)
assume "w = v"
from this pt ps show False by simp
qed
show ?thesis
proof
from u[rule_format, OF st] pt show "lookup q v = 0" by simp
next
have "∀u. v ≺⇩t u ⟶ lookup q u = 0"
proof (intro allI, intro impI)
fix u
assume "v ≺⇩t u"
from this st have "w ≺⇩t u" by simp
from u[rule_format, OF this] pu[rule_format, OF ‹v ≺⇩t u›] show "lookup q u = 0" by simp
qed
thus "higher q v = 0" by (simp only: higher_eq_zero_iff)
qed
qed
next
assume "q = p"
thus ?thesis using assms by simp
qed
lemma ord_strict_p_recI:
assumes "lt p = lt q" and "lc p = lc q" and tail: "tail p ≺⇩p tail q"
shows "p ≺⇩p q"
proof -
from tail obtain v where pt: "lookup (tail p) v = 0"
and qt: "lookup (tail q) v ≠ 0"
and a: "∀u. v ≺⇩t u ⟶ lookup (tail p) u = lookup (tail q) u"
unfolding ord_strict_p_def by auto
from qt lookup_zero[of v] have "tail q ≠ 0" by auto
from lt_max[OF qt] lt_tail[OF this] have "v ≺⇩t lt q" by simp
hence "v ≺⇩t lt p" using ‹lt p = lt q› by simp
show ?thesis unfolding ord_strict_p_def
proof (rule exI[of _ v], intro conjI allI impI)
from lookup_tail[of p v] ‹v ≺⇩t lt p› pt show "lookup p v = 0" by simp
next
from lookup_tail[of q v] ‹v ≺⇩t lt q› qt show "lookup q v ≠ 0" by simp
next
fix u
assume "v ≺⇩t u"
from this a have s: "lookup (tail p) u = lookup (tail q) u" by simp
show "lookup p u = lookup q u"
proof (cases "u = lt p")
case True
from True ‹lc p = lc q› ‹lt p = lt q› show ?thesis unfolding lc_def by simp
next
case False
from False s lookup_tail_2[of p u] lookup_tail_2[of q u] ‹lt p = lt q› show ?thesis by simp
qed
qed
qed
lemma ord_strict_p_recE1:
assumes "p ≺⇩p q"
shows "q ≠ 0"
proof
assume "q = 0"
from this assms ord_p_zero_min[of p] show False by simp
qed
lemma ord_strict_p_recE2:
assumes "p ≠ 0" and "p ≺⇩p q" and "lt p = lt q"
shows "lc p = lc q"
proof -
from ‹p ≺⇩p q› obtain v where pt: "lookup p v = 0"
and qt: "lookup q v ≠ 0"
and a: "∀u. v ≺⇩t u ⟶ lookup p u = lookup q u"
unfolding ord_strict_p_def by auto
show ?thesis
proof (cases "v ≺⇩t lt p")
case True
from this a have "lookup p (lt p) = lookup q (lt p)" by simp
thus ?thesis using ‹lt p = lt q› unfolding lc_def by simp
next
case False
from this lt_max[OF qt] ‹lt p = lt q› have "v = lt p" by simp
from this lc_not_0[OF ‹p ≠ 0›] pt show ?thesis unfolding lc_def by auto
qed
qed
lemma ord_strict_p_rec [code]:
"p ≺⇩p q =
(q ≠ 0 ∧
(p = 0 ∨
(let v1 = lt p; v2 = lt q in
(v1 ≺⇩t v2 ∨ (v1 = v2 ∧ lookup p v1 = lookup q v2 ∧ lower p v1 ≺⇩p lower q v2))
)
)
)"
(is "?L = ?R")
proof
assume ?L
show ?R
proof (intro conjI, rule ord_strict_p_recE1, fact)
have "((lt p = lt q ∧ lc p = lc q ∧ tail p ≺⇩p tail q) ∨ lt p ≺⇩t lt q) ∨ p = 0"
proof (intro disjCI)
assume "p ≠ 0" and nl: "¬ lt p ≺⇩t lt q"
from ‹?L› have "p ≼⇩p q" by simp
from ord_p_lt[OF this] nl have "lt p = lt q" by simp
show "lt p = lt q ∧ lc p = lc q ∧ tail p ≺⇩p tail q"
by (intro conjI, fact, rule ord_strict_p_recE2, fact+, rule ord_p_tail, fact+)
qed
thus "p = 0 ∨
(let v1 = lt p; v2 = lt q in
(v1 ≺⇩t v2 ∨ v1 = v2 ∧ lookup p v1 = lookup q v2 ∧ lower p v1 ≺⇩p lower q v2)
)"
unfolding lc_def tail_def by auto
qed
next
assume ?R
hence "q ≠ 0"
and dis: "p = 0 ∨
(let v1 = lt p; v2 = lt q in
(v1 ≺⇩t v2 ∨ v1 = v2 ∧ lookup p v1 = lookup q v2 ∧ lower p v1 ≺⇩p lower q v2)
)"
by simp_all
show ?L
proof (cases "p = 0")
assume "p = 0"
hence "p ≼⇩p q" using ord_p_zero_min[of q] by simp
thus ?thesis using ‹p = 0› ‹q ≠ 0› by simp
next
assume "p ≠ 0"
hence "let v1 = lt p; v2 = lt q in
(v1 ≺⇩t v2 ∨ v1 = v2 ∧ lookup p v1 = lookup q v2 ∧ lower p v1 ≺⇩p lower q v2)"
using dis by simp
hence "lt p ≺⇩t lt q ∨ (lt p = lt q ∧ lc p = lc q ∧ tail p ≺⇩p tail q)"
unfolding lc_def tail_def by (simp add: Let_def)
thus ?thesis
proof
assume "lt p ≺⇩t lt q"
from lt_ord_p[OF this] show ?thesis .
next
assume "lt p = lt q ∧ lc p = lc q ∧ tail p ≺⇩p tail q"
hence "lt p = lt q" and "lc p = lc q" and "tail p ≺⇩p tail q" by simp_all
thus ?thesis by (rule ord_strict_p_recI)
qed
qed
qed
lemma ord_strict_p_monomial_iff: "p ≺⇩p monomial c v ⟷ (c ≠ 0 ∧ (p = 0 ∨ lt p ≺⇩t v))"
proof -
from ord_p_zero_min[of "tail p"] have *: "¬ tail p ≺⇩p 0" by auto
show ?thesis
by (simp add: ord_strict_p_rec[of p] Let_def tail_def[symmetric] lc_def[symmetric]
monomial_0_iff tail_monomial *, simp add: lt_monomial cong: conj_cong)
qed
corollary ord_strict_p_monomial_plus:
assumes "p ≺⇩p monomial c v" and "q ≺⇩p monomial c v"
shows "p + q ≺⇩p monomial c v"
proof -
from assms(1) have "c ≠ 0" and "p = 0 ∨ lt p ≺⇩t v" by (simp_all add: ord_strict_p_monomial_iff)
from this(2) show ?thesis
proof
assume "p = 0"
with assms(2) show ?thesis by simp
next
assume "lt p ≺⇩t v"
from assms(2) have "q = 0 ∨ lt q ≺⇩t v" by (simp add: ord_strict_p_monomial_iff)
thus ?thesis
proof
assume "q = 0"
with assms(1) show ?thesis by simp
next
assume "lt q ≺⇩t v"
with ‹lt p ≺⇩t v› have "lt (p + q) ≺⇩t v"
using lt_plus_le_max ord_term_lin.dual_order.strict_trans2 ord_term_lin.max_less_iff_conj
by blast
with ‹c ≠ 0› show ?thesis by (simp add: ord_strict_p_monomial_iff)
qed
qed
qed
lemma ord_strict_p_monom_mult:
assumes "p ≺⇩p q" and "c ≠ (0::'b::semiring_no_zero_divisors)"
shows "monom_mult c t p ≺⇩p monom_mult c t q"
proof -
from assms(1) obtain v where 1: "lookup p v = 0" and 2: "lookup q v ≠ 0"
and 3: "⋀u. v ≺⇩t u ⟹ lookup p u = lookup q u" unfolding ord_strict_p_def by auto
show ?thesis unfolding ord_strict_p_def
proof (intro exI conjI allI impI)
from 1 show "lookup (monom_mult c t p) (t ⊕ v) = 0" by (simp add: lookup_monom_mult_plus)
next
from 2 assms(2) show "lookup (monom_mult c t q) (t ⊕ v) ≠ 0" by (simp add: lookup_monom_mult_plus)
next
fix u
assume "t ⊕ v ≺⇩t u"
show "lookup (monom_mult c t p) u = lookup (monom_mult c t q) u"
proof (cases "t adds⇩p u")
case True
then obtain w where u: "u = t ⊕ w" ..
from ‹t ⊕ v ≺⇩t u› have "v ≺⇩t w" unfolding u by (rule ord_term_strict_canc)
hence "lookup p w = lookup q w" by (rule 3)
thus ?thesis by (simp add: u lookup_monom_mult_plus)
next
case False
thus ?thesis by (simp add: lookup_monom_mult)
qed
qed
qed
lemma ord_strict_p_plus:
assumes "p ≺⇩p q" and "keys r ∩ keys q = {}"
shows "p + r ≺⇩p q + r"
proof -
from assms(1) obtain v where 1: "lookup p v = 0" and 2: "lookup q v ≠ 0"
and 3: "⋀u. v ≺⇩t u ⟹ lookup p u = lookup q u" unfolding ord_strict_p_def by auto
have eq: "lookup r v = 0"
by (meson "2" assms(2) disjoint_iff_not_equal in_keys_iff)
show ?thesis unfolding ord_strict_p_def
proof (intro exI conjI allI impI, simp_all add: lookup_add)
from 1 show "lookup p v + lookup r v = 0" by (simp add: eq)
next
from 2 show "lookup q v + lookup r v ≠ 0" by (simp add: eq)
next
fix u
assume "v ≺⇩t u"
hence "lookup p u = lookup q u" by (rule 3)
thus "lookup p u + lookup r u = lookup q u + lookup r u" by simp
qed
qed
lemma poly_mapping_tail_induct [case_names 0 tail]:
assumes "P 0" and "⋀p. p ≠ 0 ⟹ P (tail p) ⟹ P p"
shows "P p"
proof (induct "card (keys p)" arbitrary: p)
case 0
with finite_keys[of p] have "keys p = {}" by simp
hence "p = 0" by simp
from ‹P 0› show ?case unfolding ‹p = 0› .
next
case ind: (Suc n)
from ind(2) have "keys p ≠ {}" by auto
hence "p ≠ 0" by simp
thus ?case
proof (rule assms(2))
show "P (tail p)"
proof (rule ind(1))
from ‹p ≠ 0› have "lt p ∈ keys p" by (rule lt_in_keys)
hence "card (keys (tail p)) = card (keys p) - 1" by (simp add: keys_tail)
also have "... = n" unfolding ind(2)[symmetric] by simp
finally show "n = card (keys (tail p))" by simp
qed
qed
qed
lemma poly_mapping_neqE:
assumes "p ≠ q"
obtains v where "v ∈ keys p ∪ keys q" and "lookup p v ≠ lookup q v"
and "⋀u. v ≺⇩t u ⟹ lookup p u = lookup q u"
proof -
let ?A = "{v. lookup p v ≠ lookup q v}"
define v where "v = ord_term_lin.Max ?A"
have "?A ⊆ keys p ∪ keys q"
using UnI2 in_keys_iff by fastforce
also have "finite ..." by (rule finite_UnI) (fact finite_keys)+
finally(finite_subset) have fin: "finite ?A" .
moreover have "?A ≠ {}"
proof
assume "?A = {}"
hence "p = q"
using poly_mapping_eqI by fastforce
with assms show False ..
qed
ultimately have "v ∈ ?A" unfolding v_def by (rule ord_term_lin.Max_in)
show ?thesis
proof
from ‹?A ⊆ keys p ∪ keys q› ‹v ∈ ?A› show "v ∈ keys p ∪ keys q" ..
next
from ‹v ∈ ?A› show "lookup p v ≠ lookup q v" by simp
next
fix u
assume "v ≺⇩t u"
show "lookup p u = lookup q u"
proof (rule ccontr)
assume "lookup p u ≠ lookup q u"
hence "u ∈ ?A" by simp
with fin have "u ≼⇩t v" unfolding v_def by (rule ord_term_lin.Max_ge)
with ‹v ≺⇩t u› show False by simp
qed
qed
qed
subsection ‹Monomials›
lemma keys_monomial:
assumes "is_monomial p"
shows "keys p = {lt p}"
using assms by (metis is_monomial_monomial lt_monomial keys_of_monomial)
lemma monomial_eq_itself:
assumes "is_monomial p"
shows "monomial (lc p) (lt p) = p"
proof -
from assms have "p ≠ 0" by (rule monomial_not_0)
hence "lc p ≠ 0" by (rule lc_not_0)
hence keys1: "keys (monomial (lc p) (lt p)) = {lt p}" by (rule keys_of_monomial)
show ?thesis
by (rule poly_mapping_keys_eqI, simp only: keys_monomial[OF assms] keys1,
simp only: keys1 lookup_single Poly_Mapping.when_def, auto simp add: lc_def)
qed
lemma lt_eq_min_term_monomial:
assumes "lt p = min_term"
shows "monomial (lc p) min_term = p"
proof (rule poly_mapping_eqI)
fix v
from min_term_min[of v] have "v = min_term ∨ min_term ≺⇩t v" by auto
thus "lookup (monomial (lc p) min_term) v = lookup p v"
proof
assume "v = min_term"
thus ?thesis by (simp add: lookup_single lc_def assms)
next
assume "min_term ≺⇩t v"
moreover have "v ∉ keys p"
proof
assume "v ∈ keys p"
hence "v ≼⇩t lt p" by (rule lt_max_keys)
with ‹min_term ≺⇩t v› show False by (simp add: assms)
qed
ultimately show ?thesis by (simp add: lookup_single in_keys_iff)
qed
qed
lemma is_monomial_monomial_ordered:
assumes "is_monomial p"
obtains c v where "c ≠ 0" and "lc p = c" and "lt p = v" and "p = monomial c v"
proof -
from assms obtain c v where "c ≠ 0" and p_eq: "p = monomial c v" by (rule is_monomial_monomial)
note this(1)
moreover have "lc p = c" unfolding p_eq by (rule lc_monomial)
moreover from ‹c ≠ 0› have "lt p = v" unfolding p_eq by (rule lt_monomial)
ultimately show ?thesis using p_eq ..
qed
lemma monomial_plus_not_0:
assumes "c ≠ 0" and "lt p ≺⇩t v"
shows "monomial c v + p ≠ 0"
proof
assume "monomial c v + p = 0"
hence "0 = lookup (monomial c v + p) v" by simp
also have "... = c + lookup p v" by (simp add: lookup_add)
also have "... = c"
proof -
from assms(2) have "¬ v ≼⇩t lt p" by simp
with lt_max[of p v] have "lookup p v = 0" by blast
thus ?thesis by simp
qed
finally show False using ‹c ≠ 0› by simp
qed
lemma lt_monomial_plus:
assumes "c ≠ (0::'b::comm_monoid_add)" and "lt p ≺⇩t v"
shows "lt (monomial c v + p) = v"
proof -
have eq: "lt (monomial c v) = v" by (simp only: lt_monomial[OF ‹c ≠ 0›])
moreover have "lt (p + monomial c v) = lt (monomial c v)" by (rule lt_plus_eqI, simp only: eq, fact)
ultimately show ?thesis by (simp add: add.commute)
qed
lemma lc_monomial_plus:
assumes "c ≠ (0::'b::comm_monoid_add)" and "lt p ≺⇩t v"
shows "lc (monomial c v + p) = c"
proof -
from assms(2) have "¬ v ≼⇩t lt p" by simp
with lt_max[of p v] have "lookup p v = 0" by blast
thus ?thesis by (simp add: lc_def lt_monomial_plus[OF assms] lookup_add)
qed
lemma tt_monomial_plus:
assumes "p ≠ (0::_ ⇒⇩0 'b::comm_monoid_add)" and "lt p ≺⇩t v"
shows "tt (monomial c v + p) = tt p"
proof (cases "c = 0")
case True
thus ?thesis by (simp add: monomial_0I)
next
case False
have eq: "tt (monomial c v) = v" by (simp only: tt_monomial[OF ‹c ≠ 0›])
moreover have "tt (p + monomial c v) = tt p"
proof (rule tt_plus_eqI, fact, simp only: eq)
from lt_ge_tt[of p] assms(2) show "tt p ≺⇩t v" by simp
qed
ultimately show ?thesis by (simp add: ac_simps)
qed
lemma tc_monomial_plus:
assumes "p ≠ (0::_ ⇒⇩0 'b::comm_monoid_add)" and "lt p ≺⇩t v"
shows "tc (monomial c v + p) = tc p"
proof (simp add: tc_def tt_monomial_plus[OF assms] lookup_add lookup_single Poly_Mapping.when_def,
rule impI)
assume "v = tt p"
with assms(2) have "lt p ≺⇩t tt p" by simp
with lt_ge_tt[of p] show "c + lookup p (tt p) = lookup p (tt p)" by simp
qed
lemma tail_monomial_plus:
assumes "c ≠ (0::'b::comm_monoid_add)" and "lt p ≺⇩t v"
shows "tail (monomial c v + p) = p" (is "tail ?q = _")
proof -
from assms have "lt ?q = v" by (rule lt_monomial_plus)
moreover have "lower (monomial c v) v = 0"
by (simp add: lower_eq_zero_iff', rule disjI2, simp add: tt_monomial[OF ‹c ≠ 0›])
ultimately show ?thesis by (simp add: tail_def lower_plus lower_id_iff, intro disjI2 assms(2))
qed
subsection ‹Lists of Keys›
text ‹In algorithms one very often needs to compute the sorted list of all terms appearing
in a list of polynomials.›
definition pps_to_list :: "'t set ⇒ 't list" where
"pps_to_list S = rev (ord_term_lin.sorted_list_of_set S)"
definition keys_to_list :: "('t ⇒⇩0 'b::zero) ⇒ 't list"
where "keys_to_list p = pps_to_list (keys p)"
definition Keys_to_list :: "('t ⇒⇩0 'b::zero) list ⇒ 't list"
where "Keys_to_list ps = fold (λp ts. merge_wrt (≻⇩t) (keys_to_list p) ts) ps []"
text ‹Function @{const pps_to_list} turns finite sets of terms into sorted lists, where the
lists are sorted descending (i.\,e. greater elements come before smaller ones).›
lemma distinct_pps_to_list: "distinct (pps_to_list S)"
unfolding pps_to_list_def distinct_rev by (rule ord_term_lin.distinct_sorted_list_of_set)
lemma set_pps_to_list:
assumes "finite S"
shows "set (pps_to_list S) = S"
unfolding pps_to_list_def set_rev using assms by simp
lemma length_pps_to_list: "length (pps_to_list S) = card S"
proof (cases "finite S")
case True
from distinct_card[OF distinct_pps_to_list] have "length (pps_to_list S) = card (set (pps_to_list S))"
by simp
also from True have "... = card S" by (simp only: set_pps_to_list)
finally show ?thesis .
next
case False
thus ?thesis by (simp add: pps_to_list_def)
qed
lemma pps_to_list_sorted_wrt: "sorted_wrt (≻⇩t) (pps_to_list S)"
proof -
have "sorted_wrt (≽⇩t) (pps_to_list S)"
proof -
have tr: "transp (≼⇩t)" using transp_def by fastforce
have *: "(λx y. y ≽⇩t x) = (≼⇩t)" by simp
show ?thesis
by (simp only: * pps_to_list_def sorted_wrt_rev ord_term_lin.sorted_sorted_wrt[symmetric],
rule ord_term_lin.sorted_sorted_list_of_set)
qed
with distinct_pps_to_list have "sorted_wrt (λx y. x ≽⇩t y ∧ x ≠ y) (pps_to_list S)"
by (rule distinct_sorted_wrt_imp_sorted_wrt_strict)
moreover have "(≻⇩t) = (λx y. x ≽⇩t y ∧ x ≠ y)"
using ord_term_lin.dual_order.order_iff_strict by auto
ultimately show ?thesis by simp
qed
lemma pps_to_list_nth_leI:
assumes "j ≤ i" and "i < card S"
shows "(pps_to_list S) ! i ≼⇩t (pps_to_list S) ! j"
proof (cases "j = i")
case True
show ?thesis by (simp add: True)
next
case False
with assms(1) have "j < i" by simp
let ?ts = "pps_to_list S"
from pps_to_list_sorted_wrt ‹j < i› have "(≺⇩t)¯¯ (?ts ! j) (?ts ! i)"
proof (rule sorted_wrt_nth_less)
from assms(2) show "i < length ?ts" by (simp only: length_pps_to_list)
qed
thus ?thesis by simp
qed
lemma pps_to_list_nth_lessI:
assumes "j < i" and "i < card S"
shows "(pps_to_list S) ! i ≺⇩t (pps_to_list S) ! j"
proof -
let ?ts = "pps_to_list S"
from assms(1) have "j ≤ i" and "i ≠ j" by simp_all
with assms(2) have "i < length ?ts" and "j < length ?ts" by (simp_all only: length_pps_to_list)
show ?thesis
proof (rule ord_term_lin.neq_le_trans)
from ‹i ≠ j› show "?ts ! i ≠ ?ts ! j"
by (simp add: nth_eq_iff_index_eq[OF distinct_pps_to_list ‹i < length ?ts› ‹j < length ?ts›])
next
from ‹j ≤ i› assms(2) show "?ts ! i ≼⇩t ?ts ! j" by (rule pps_to_list_nth_leI)
qed
qed
lemma pps_to_list_nth_leD:
assumes "(pps_to_list S) ! i ≼⇩t (pps_to_list S) ! j" and "j < card S"
shows "j ≤ i"
proof (rule ccontr)
assume "¬ j ≤ i"
hence "i < j" by simp
from this ‹j < card S› have "(pps_to_list S) ! j ≺⇩t (pps_to_list S) ! i" by (rule pps_to_list_nth_lessI)
with assms(1) show False by simp
qed
lemma pps_to_list_nth_lessD:
assumes "(pps_to_list S) ! i ≺⇩t (pps_to_list S) ! j" and "j < card S"
shows "j < i"
proof (rule ccontr)
assume "¬ j < i"
hence "i ≤ j" by simp
from this ‹j < card S› have "(pps_to_list S) ! j ≼⇩t (pps_to_list S) ! i" by (rule pps_to_list_nth_leI)
with assms(1) show False by simp
qed
lemma set_keys_to_list: "set (keys_to_list p) = keys p"
by (simp add: keys_to_list_def set_pps_to_list)
lemma length_keys_to_list: "length (keys_to_list p) = card (keys p)"
by (simp only: keys_to_list_def length_pps_to_list)
lemma keys_to_list_zero [simp]: "keys_to_list 0 = []"
by (simp add: keys_to_list_def pps_to_list_def)
lemma Keys_to_list_Nil [simp]: "Keys_to_list [] = []"
by (simp add: Keys_to_list_def)
lemma set_Keys_to_list: "set (Keys_to_list ps) = Keys (set ps)"
proof -
have "set (Keys_to_list ps) = (⋃p∈set ps. set (keys_to_list p)) ∪ set []"
unfolding Keys_to_list_def by (rule set_fold, simp only: set_merge_wrt)
also have "... = Keys (set ps)" by (simp add: Keys_def set_keys_to_list)
finally show ?thesis .
qed
lemma Keys_to_list_sorted_wrt_aux:
assumes "sorted_wrt (≻⇩t) ts"
shows "sorted_wrt (≻⇩t) (fold (λp ts. merge_wrt (≻⇩t) (keys_to_list p) ts) ps ts)"
using assms
proof (induct ps arbitrary: ts)
case Nil
thus ?case by simp
next
case (Cons p ps)
show ?case
proof (simp only: fold.simps o_def, rule Cons(1), rule sorted_merge_wrt)
show "transp (≻⇩t)" unfolding transp_def by fastforce
next
fix x y :: 't
assume "x ≠ y"
thus "x ≻⇩t y ∨ y ≻⇩t x" by auto
next
show "sorted_wrt (≻⇩t) (keys_to_list p)" unfolding keys_to_list_def
by (fact pps_to_list_sorted_wrt)
qed fact
qed
corollary Keys_to_list_sorted_wrt: "sorted_wrt (≻⇩t) (Keys_to_list ps)"
unfolding Keys_to_list_def
proof (rule Keys_to_list_sorted_wrt_aux)
show "sorted_wrt (≻⇩t) []" by simp
qed
corollary distinct_Keys_to_list: "distinct (Keys_to_list ps)"
proof (rule distinct_sorted_wrt_irrefl)
show "irreflp (≻⇩t)" by (simp add: irreflp_def)
next
show "transp (≻⇩t)" unfolding transp_def by fastforce
next
show "sorted_wrt (≻⇩t) (Keys_to_list ps)" by (fact Keys_to_list_sorted_wrt)
qed
lemma length_Keys_to_list: "length (Keys_to_list ps) = card (Keys (set ps))"
proof -
from distinct_Keys_to_list have "card (set (Keys_to_list ps)) = length (Keys_to_list ps)"
by (rule distinct_card)
thus ?thesis by (simp only: set_Keys_to_list)
qed
lemma Keys_to_list_eq_pps_to_list: "Keys_to_list ps = pps_to_list (Keys (set ps))"
using _ Keys_to_list_sorted_wrt distinct_Keys_to_list pps_to_list_sorted_wrt distinct_pps_to_list
proof (rule sorted_wrt_distinct_set_unique)
show "antisymp (≻⇩t)" unfolding antisymp_def by fastforce
next
from finite_set have fin: "finite (Keys (set ps))" by (rule finite_Keys)
show "set (Keys_to_list ps) = set (pps_to_list (Keys (set ps)))"
by (simp add: set_Keys_to_list set_pps_to_list[OF fin])
qed
subsection ‹Multiplication›
lemma in_keys_mult_scalar_le:
assumes "v ∈ keys (p ⊙ q)"
shows "v ≼⇩t punit.lt p ⊕ lt q"
proof -
from assms obtain t u where "t ∈ keys p" and "u ∈ keys q" and "v = t ⊕ u"
by (rule in_keys_mult_scalarE)
from ‹t ∈ keys p› have "t ≼ punit.lt p" by (rule punit.lt_max_keys)
from ‹u ∈ keys q› have "u ≼⇩t lt q" by (rule lt_max_keys)
hence "v ≼⇩t t ⊕ lt q" unfolding ‹v = t ⊕ u› by (rule splus_mono)
also from ‹t ≼ punit.lt p› have "... ≼⇩t punit.lt p ⊕ lt q" by (rule splus_mono_left)
finally show ?thesis .
qed
lemma in_keys_mult_scalar_ge:
assumes "v ∈ keys (p ⊙ q)"
shows "punit.tt p ⊕ tt q ≼⇩t v"
proof -
from assms obtain t u where "t ∈ keys p" and "u ∈ keys q" and "v = t ⊕ u"
by (rule in_keys_mult_scalarE)
from ‹t ∈ keys p› have "punit.tt p ≼ t" by (rule punit.tt_min_keys)
from ‹u ∈ keys q› have "tt q ≼⇩t u" by (rule tt_min_keys)
hence "punit.tt p ⊕ tt q ≼⇩t punit.tt p ⊕ u" by (rule splus_mono)
also from ‹punit.tt p ≼ t› have "... ≼⇩t v" unfolding ‹v = t ⊕ u› by (rule splus_mono_left)
finally show ?thesis .
qed
lemma (in ordered_term) lookup_mult_scalar_lt_lt:
"lookup (p ⊙ q) (punit.lt p ⊕ lt q) = punit.lc p * lc q"
proof (induct p rule: punit.poly_mapping_tail_induct)
case 0
show ?case by simp
next
case step: (tail p)
from step(1) have "punit.lc p ≠ 0" by (rule punit.lc_not_0)
let ?t = "punit.lt p ⊕ lt q"
show ?case
proof (cases "is_monomial p")
case True
then obtain c t where "c ≠ 0" and "punit.lt p = t" and "punit.lc p = c" and p_eq: "p = monomial c t"
by (rule punit.is_monomial_monomial_ordered)
hence "p ⊙ q = monom_mult (punit.lc p) (punit.lt p) q" by (simp add: mult_scalar_monomial)
thus ?thesis by (simp add: lookup_monom_mult_plus lc_def)
next
case False
have "punit.lt (punit.tail p) ≠ punit.lt p"
proof (simp add: punit.tail_def punit.lt_lower_eq_iff, rule)
assume "punit.lt p = 0"
have "keys p ⊆ {punit.lt p}"
proof (rule, simp)
fix s
assume "s ∈ keys p"
hence "s ≼ punit.lt p" by (rule punit.lt_max_keys)
moreover have "punit.lt p ≼ s" unfolding ‹punit.lt p = 0› by (rule zero_min)
ultimately show "s = punit.lt p" by simp
qed
hence "card (keys p) = 0 ∨ card (keys p) = 1" using subset_singletonD by fastforce
thus False
proof
assume "card (keys p) = 0"
hence "p = 0" by (meson card_0_eq keys_eq_empty finite_keys)
with step(1) show False ..
next
assume "card (keys p) = 1"
with False show False unfolding is_monomial_def ..
qed
qed
with punit.lt_lower[of p "punit.lt p"] have "punit.lt (punit.tail p) ≺ punit.lt p"
by (simp add: punit.tail_def)
have eq: "lookup ((punit.tail p) ⊙ q) ?t = 0"
proof (rule ccontr)
assume "lookup ((punit.tail p) ⊙ q) ?t ≠ 0"
hence "?t ≼⇩t punit.lt (punit.tail p) ⊕ lt q"
by (meson in_keys_mult_scalar_le lookup_not_eq_zero_eq_in_keys)
hence "punit.lt p ≼ punit.lt (punit.tail p)" by (rule ord_term_canc_left)
also have "... ≺ punit.lt p" by fact
finally show False ..
qed
from step(2) have "lookup (monom_mult (punit.lc p) (punit.lt p) q) ?t = punit.lc p * lc q"
by (simp only: lookup_monom_mult_plus lc_def)
thus ?thesis by (simp add: mult_scalar_tail_rec_left[of p q] lookup_add eq)
qed
qed
lemma lookup_mult_scalar_tt_tt: "lookup (p ⊙ q) (punit.tt p ⊕ tt q) = punit.tc p * tc q"
proof (induct p rule: punit.poly_mapping_tail_induct)
case 0
show ?case by simp
next
case step: (tail p)
from step(1) have "punit.lc p ≠ 0" by (rule punit.lc_not_0)
let ?t = "punit.tt p ⊕ tt q"
show ?case
proof (cases "is_monomial p")
case True
then obtain c t where "c ≠ 0" and "punit.lt p = t" and "punit.lc p = c" and p_eq: "p = monomial c t"
by (rule punit.is_monomial_monomial_ordered)
from ‹c ≠ 0› have "punit.tt p = t" and "punit.tc p = c" by (simp_all add: p_eq punit.tt_monomial)
with p_eq have "p ⊙ q = monom_mult (punit.tc p) (punit.tt p) q" by (simp add: mult_scalar_monomial)
thus ?thesis by (simp add: lookup_monom_mult_plus tc_def)
next
case False
from step(1) have "keys p ≠ {}" by simp
with finite_keys have "card (keys p) ≠ 0" by auto
with False have "2 ≤ card (keys p)" unfolding is_monomial_def by linarith
then obtain s t where "s ∈ keys p" and "t ∈ keys p" and "s ≺ t"
by (metis (mono_tags, lifting) card.empty card.infinite card_insert_disjoint card_mono empty_iff
finite.emptyI insertCI lessI not_less numeral_2_eq_2 ordered_powerprod_lin.infinite_growing
ordered_powerprod_lin.neqE preorder_class.less_le_trans subsetI)
from this(1) this(3) have "punit.tt p ≺ t" by (rule punit.tt_less)
also from ‹t ∈ keys p› have "t ≼ punit.lt p" by (rule punit.lt_max_keys)
finally have "punit.tt p ≺ punit.lt p" .
hence tt_tail: "punit.tt (punit.tail p) = punit.tt p" and tc_tail: "punit.tc (punit.tail p) = punit.tc p"
unfolding punit.tail_def by (rule punit.tt_lower, rule punit.tc_lower)
have eq: "lookup (monom_mult (punit.lc p) (punit.lt p) q) ?t = 0"
proof (rule ccontr)
assume "lookup (monom_mult (punit.lc p) (punit.lt p) q) ?t ≠ 0"
hence "punit.lt p ⊕ tt q ≼⇩t ?t"
by (meson in_keys_iff in_keys_monom_mult_ge)
hence "punit.lt p ≼ punit.tt p" by (rule ord_term_canc_left)
also have "... ≺ punit.lt p" by fact
finally show False ..
qed
from step(2) have "lookup (punit.tail p ⊙ q) ?t = punit.tc p * tc q" by (simp only: tt_tail tc_tail)
thus ?thesis by (simp add: mult_scalar_tail_rec_left[of p q] lookup_add eq)
qed
qed
lemma lt_mult_scalar:
assumes "p ≠ 0" and "q ≠ (0::'t ⇒⇩0 'b::semiring_no_zero_divisors)"
shows "lt (p ⊙ q) = punit.lt p ⊕ lt q"
proof (rule lt_eqI_keys, simp only: in_keys_iff lookup_mult_scalar_lt_lt)
from assms(1) have "punit.lc p ≠ 0" by (rule punit.lc_not_0)
moreover from assms(2) have "lc q ≠ 0" by (rule lc_not_0)
ultimately show "punit.lc p * lc q ≠ 0" by simp
qed (rule in_keys_mult_scalar_le)
lemma tt_mult_scalar:
assumes "p ≠ 0" and "q ≠ (0::'t ⇒⇩0 'b::semiring_no_zero_divisors)"
shows "tt (p ⊙ q) = punit.tt p ⊕ tt q"
proof (rule tt_eqI, simp only: in_keys_iff lookup_mult_scalar_tt_tt)
from assms(1) have "punit.tc p ≠ 0" by (rule punit.tc_not_0)
moreover from assms(2) have "tc q ≠ 0" by (rule tc_not_0)
ultimately show "punit.tc p * tc q ≠ 0" by simp
qed (rule in_keys_mult_scalar_ge)
lemma lc_mult_scalar: "lc (p ⊙ q) = punit.lc p * lc (q::'t ⇒⇩0 'b::semiring_no_zero_divisors)"
proof (cases "p = 0")
case True
thus ?thesis by (simp add: lc_def)
next
case False
show ?thesis
proof (cases "q = 0")
case True
thus ?thesis by (simp add: lc_def)
next
case False
with ‹p ≠ 0› show ?thesis by (simp add: lc_def lt_mult_scalar lookup_mult_scalar_lt_lt)
qed
qed
lemma tc_mult_scalar: "tc (p ⊙ q) = punit.tc p * tc (q::'t ⇒⇩0 'b::semiring_no_zero_divisors)"
proof (cases "p = 0")
case True
thus ?thesis by (simp add: tc_def)
next
case False
show ?thesis
proof (cases "q = 0")
case True
thus ?thesis by (simp add: tc_def)
next
case False
with ‹p ≠ 0› show ?thesis by (simp add: tc_def tt_mult_scalar lookup_mult_scalar_tt_tt)
qed
qed
lemma mult_scalar_not_zero:
assumes "p ≠ 0" and "q ≠ (0::'t ⇒⇩0 'b::semiring_no_zero_divisors)"
shows "p ⊙ q ≠ 0"
proof
assume "p ⊙ q = 0"
hence "0 = lc (p ⊙ q)" by (simp add: lc_def)
also have "... = punit.lc p * lc q" by (rule lc_mult_scalar)
finally have "punit.lc p * lc q = 0" by simp
moreover from assms(1) have "punit.lc p ≠ 0" by (rule punit.lc_not_0)
moreover from assms(2) have "lc q ≠ 0" by (rule lc_not_0)
ultimately show False by simp
qed
end
context ordered_powerprod
begin
lemmas in_keys_times_le = punit.in_keys_mult_scalar_le[simplified]
lemmas in_keys_times_ge = punit.in_keys_mult_scalar_ge[simplified]
lemmas lookup_times_lp_lp = punit.lookup_mult_scalar_lt_lt[simplified]
lemmas lookup_times_tp_tp = punit.lookup_mult_scalar_tt_tt[simplified]
lemmas lookup_times_monomial_right_plus = punit.lookup_mult_scalar_monomial_right_plus[simplified]
lemmas lookup_times_monomial_right = punit.lookup_mult_scalar_monomial_right[simplified]
lemmas lp_times = punit.lt_mult_scalar[simplified]
lemmas tp_times = punit.tt_mult_scalar[simplified]
lemmas lc_times = punit.lc_mult_scalar[simplified]
lemmas tc_times = punit.tc_mult_scalar[simplified]
lemmas times_not_zero = punit.mult_scalar_not_zero[simplified]
lemmas times_tail_rec_left = punit.mult_scalar_tail_rec_left[simplified]
lemmas times_tail_rec_right = punit.mult_scalar_tail_rec_right[simplified]
lemmas punit_in_keys_monom_mult_le = punit.in_keys_monom_mult_le[simplified]
lemmas punit_in_keys_monom_mult_ge = punit.in_keys_monom_mult_ge[simplified]
lemmas lp_monom_mult = punit.lt_monom_mult[simplified]
lemmas tp_monom_mult = punit.tt_monom_mult[simplified]
end
subsection ‹@{term dgrad_p_set} and @{term dgrad_p_set_le}›
locale gd_term =
ordered_term pair_of_term term_of_pair ord ord_strict ord_term ord_term_strict
for pair_of_term::"'t ⇒ ('a::graded_dickson_powerprod × 'k::{the_min,wellorder})"
and term_of_pair::"('a × 'k) ⇒ 't"
and ord::"'a ⇒ 'a ⇒ bool" (infixl "≼" 50)
and ord_strict (infixl "≺" 50)
and ord_term::"'t ⇒ 't ⇒ bool" (infixl "≼⇩t" 50)
and ord_term_strict::"'t ⇒ 't ⇒ bool" (infixl "≺⇩t" 50)
begin
sublocale gd_powerprod ..
lemma adds_term_antisym:
assumes "u adds⇩t v" and "v adds⇩t u"
shows "u = v"
using assms unfolding adds_term_def using adds_antisym by (metis term_of_pair_pair)
definition dgrad_p_set :: "('a ⇒ nat) ⇒ nat ⇒ ('t ⇒⇩0 'b::zero) set"
where "dgrad_p_set d m = {p. pp_of_term ` keys p ⊆ dgrad_set d m}"
definition dgrad_p_set_le :: "('a ⇒ nat) ⇒ (('t ⇒⇩0 'b) set) ⇒ (('t ⇒⇩0 'b::zero) set) ⇒ bool"
where "dgrad_p_set_le d F G ⟷ (dgrad_set_le d (pp_of_term ` Keys F) (pp_of_term ` Keys G))"
lemma in_dgrad_p_set_iff: "p ∈ dgrad_p_set d m ⟷ (∀v∈keys p. d (pp_of_term v) ≤ m)"
by (auto simp add: dgrad_p_set_def dgrad_set_def)
lemma dgrad_p_setI [intro]:
assumes "⋀v. v ∈ keys p ⟹ d (pp_of_term v) ≤ m"
shows "p ∈ dgrad_p_set d m"
using assms by (auto simp: in_dgrad_p_set_iff)
lemma dgrad_p_setD:
assumes "p ∈ dgrad_p_set d m" and "v ∈ keys p"
shows "d (pp_of_term v) ≤ m"
using assms by (simp only: in_dgrad_p_set_iff)
lemma zero_in_dgrad_p_set: "0 ∈ dgrad_p_set d m"
by (rule, simp)
lemma dgrad_p_set_zero [simp]: "dgrad_p_set (λ_. 0) m = UNIV"
by auto
lemma subset_dgrad_p_set_zero: "F ⊆ dgrad_p_set (λ_. 0) m"
by simp
lemma dgrad_p_set_subset:
assumes "m ≤ n"
shows "dgrad_p_set d m ⊆ dgrad_p_set d n"
using assms by (auto simp: dgrad_p_set_def dgrad_set_def)
lemma dgrad_p_setD_lp:
assumes "p ∈ dgrad_p_set d m" and "p ≠ 0"
shows "d (lp p) ≤ m"
by (rule dgrad_p_setD, fact, rule lt_in_keys, fact)
lemma dgrad_p_set_exhaust_expl:
assumes "finite F"
shows "F ⊆ dgrad_p_set d (Max (d ` pp_of_term ` Keys F))"
proof
fix f
assume "f ∈ F"
from assms have "finite (Keys F)" by (rule finite_Keys)
have fin: "finite (d ` pp_of_term ` Keys F)" by (intro finite_imageI, fact)
show "f ∈ dgrad_p_set d (Max (d ` pp_of_term ` Keys F))"
proof (rule dgrad_p_setI)
fix v
assume "v ∈ keys f"
from this ‹f ∈ F› have "v ∈ Keys F" by (rule in_KeysI)
hence "d (pp_of_term v) ∈ d ` pp_of_term ` Keys F" by simp
with fin show "d (pp_of_term v) ≤ Max (d ` pp_of_term ` Keys F)" by (rule Max_ge)
qed
qed
lemma dgrad_p_set_exhaust:
assumes "finite F"
obtains m where "F ⊆ dgrad_p_set d m"
proof
from assms show "F ⊆ dgrad_p_set d (Max (d ` pp_of_term ` Keys F))" by (rule dgrad_p_set_exhaust_expl)
qed
lemma dgrad_p_set_insert:
assumes "F ⊆ dgrad_p_set d m"
obtains n where "m ≤ n" and "f ∈ dgrad_p_set d n" and "F ⊆ dgrad_p_set d n"
proof -
have "finite {f}" by simp
then obtain m1 where "{f} ⊆ dgrad_p_set d m1" by (rule dgrad_p_set_exhaust)
hence "f ∈ dgrad_p_set d m1" by simp
define n where "n = ord_class.max m m1"
have "m ≤ n" and "m1 ≤ n" by (simp_all add: n_def)
from this(1) show ?thesis
proof
from ‹m1 ≤ n› have "dgrad_p_set d m1 ⊆ dgrad_p_set d n" by (rule dgrad_p_set_subset)
with ‹f ∈ dgrad_p_set d m1› show "f ∈ dgrad_p_set d n" ..
next
from ‹m ≤ n› have "dgrad_p_set d m ⊆ dgrad_p_set d n" by (rule dgrad_p_set_subset)
with assms show "F ⊆ dgrad_p_set d n" by (rule subset_trans)
qed
qed
lemma dgrad_p_set_leI:
assumes "⋀f. f ∈ F ⟹ dgrad_p_set_le d {f} G"
shows "dgrad_p_set_le d F G"
unfolding dgrad_p_set_le_def dgrad_set_le_def
proof
fix s
assume "s ∈ pp_of_term ` Keys F"
then obtain v where "v ∈ Keys F" and "s = pp_of_term v" ..
from this(1) obtain f where "f ∈ F" and "v ∈ keys f" by (rule in_KeysE)
from this(2) have "s ∈ pp_of_term ` Keys {f}" by (simp add: ‹s = pp_of_term v› Keys_insert)
from ‹f ∈ F› have "dgrad_p_set_le d {f} G" by (rule assms)
from this ‹s ∈ pp_of_term ` Keys {f}› show "∃t∈pp_of_term ` Keys G. d s ≤ d t"
unfolding dgrad_p_set_le_def dgrad_set_le_def ..
qed
lemma dgrad_p_set_le_trans [trans]:
assumes "dgrad_p_set_le d F G" and "dgrad_p_set_le d G H"
shows "dgrad_p_set_le d F H"
using assms unfolding dgrad_p_set_le_def by (rule dgrad_set_le_trans)
lemma dgrad_p_set_le_subset:
assumes "F ⊆ G"
shows "dgrad_p_set_le d F G"
unfolding dgrad_p_set_le_def by (rule dgrad_set_le_subset, rule image_mono, rule Keys_mono, fact)
lemma dgrad_p_set_leI_insert_keys:
assumes "dgrad_p_set_le d F G" and "dgrad_set_le d (pp_of_term ` keys f) (pp_of_term ` Keys G)"
shows "dgrad_p_set_le d (insert f F) G"
using assms by (simp add: dgrad_p_set_le_def Keys_insert dgrad_set_le_Un image_Un)
lemma dgrad_p_set_leI_insert:
assumes "dgrad_p_set_le d F G" and "dgrad_p_set_le d {f} G"
shows "dgrad_p_set_le d (insert f F) G"
using assms by (simp add: dgrad_p_set_le_def Keys_insert dgrad_set_le_Un image_Un)
lemma dgrad_p_set_leI_Un:
assumes "dgrad_p_set_le d F1 G" and "dgrad_p_set_le d F2 G"
shows "dgrad_p_set_le d (F1 ∪ F2) G"
using assms by (auto simp: dgrad_p_set_le_def dgrad_set_le_def Keys_Un)
lemma dgrad_p_set_le_dgrad_p_set:
assumes "dgrad_p_set_le d F G" and "G ⊆ dgrad_p_set d m"
shows "F ⊆ dgrad_p_set d m"
proof
fix f
assume "f ∈ F"
show "f ∈ dgrad_p_set d m"
proof (rule dgrad_p_setI)
fix v
assume "v ∈ keys f"
from this ‹f ∈ F› have "v ∈ Keys F" by (rule in_KeysI)
hence "pp_of_term v ∈ pp_of_term ` Keys F" by simp
with assms(1) obtain s where "s ∈ pp_of_term ` Keys G" and "d (pp_of_term v) ≤ d s"
unfolding dgrad_p_set_le_def by (rule dgrad_set_leE)
from this(1) obtain u where "u ∈ Keys G" and s: "s = pp_of_term u" ..
from this(1) obtain g where "g ∈ G" and "u ∈ keys g" by (rule in_KeysE)
from this(1) assms(2) have "g ∈ dgrad_p_set d m" ..
from this ‹u ∈ keys g› have "d s ≤ m" unfolding s by (rule dgrad_p_setD)
with ‹d (pp_of_term v) ≤ d s› show "d (pp_of_term v) ≤ m" by (rule le_trans)
qed
qed
lemma dgrad_p_set_le_except: "dgrad_p_set_le d {except p S} {p}"
by (auto simp add: dgrad_p_set_le_def Keys_insert keys_except intro: dgrad_set_le_subset)
lemma dgrad_p_set_le_tail: "dgrad_p_set_le d {tail p} {p}"
by (simp only: tail_def lower_def, fact dgrad_p_set_le_except)
lemma dgrad_p_set_le_plus: "dgrad_p_set_le d {p + q} {p, q}"
by (simp add: dgrad_p_set_le_def Keys_insert, rule dgrad_set_le_subset, rule image_mono, fact Poly_Mapping.keys_add)
lemma dgrad_p_set_le_uminus: "dgrad_p_set_le d {-p} {p}"
by (simp add: dgrad_p_set_le_def Keys_insert keys_uminus, fact dgrad_set_le_refl)
lemma dgrad_p_set_le_minus: "dgrad_p_set_le d {p - q} {p, q}"
by (simp add: dgrad_p_set_le_def Keys_insert, rule dgrad_set_le_subset, rule image_mono, fact keys_minus)
lemma dgrad_set_le_monom_mult:
assumes "dickson_grading d"
shows "dgrad_set_le d (pp_of_term ` keys (monom_mult c t p)) (insert t (pp_of_term ` keys p))"
proof (rule dgrad_set_leI)
fix s
assume "s ∈ pp_of_term ` keys (monom_mult c t p)"
with keys_monom_mult_subset have "s ∈ pp_of_term ` ((⊕) t ` keys p)" by fastforce
then obtain v where "v ∈ keys p" and s: "s = pp_of_term (t ⊕ v)" by fastforce
have "d s = ord_class.max (d t) (d (pp_of_term v))"
by (simp only: s pp_of_term_splus dickson_gradingD1[OF assms(1)])
hence "d s = d t ∨ d s = d (pp_of_term v)" by auto
thus "∃t∈insert t (pp_of_term ` keys p). d s ≤ d t"
proof
assume "d s = d t"
thus ?thesis by simp
next
assume "d s = d (pp_of_term v)"
show ?thesis
proof
from ‹d s = d (pp_of_term v)› show "d s ≤ d (pp_of_term v)" by simp
next
from ‹v ∈ keys p› show "pp_of_term v ∈ insert t (pp_of_term ` keys p)" by simp
qed
qed
qed
lemma dgrad_p_set_closed_plus:
assumes "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m"
shows "p + q ∈ dgrad_p_set d m"
proof -
from dgrad_p_set_le_plus have "{p + q} ⊆ dgrad_p_set d m"
proof (rule dgrad_p_set_le_dgrad_p_set)
from assms show "{p, q} ⊆ dgrad_p_set d m" by simp
qed
thus ?thesis by simp
qed
lemma dgrad_p_set_closed_uminus:
assumes "p ∈ dgrad_p_set d m"
shows "-p ∈ dgrad_p_set d m"
proof -
from dgrad_p_set_le_uminus have "{-p} ⊆ dgrad_p_set d m"
proof (rule dgrad_p_set_le_dgrad_p_set)
from assms show "{p} ⊆ dgrad_p_set d m" by simp
qed
thus ?thesis by simp
qed
lemma dgrad_p_set_closed_minus:
assumes "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m"
shows "p - q ∈ dgrad_p_set d m"
proof -
from dgrad_p_set_le_minus have "{p - q} ⊆ dgrad_p_set d m"
proof (rule dgrad_p_set_le_dgrad_p_set)
from assms show "{p, q} ⊆ dgrad_p_set d m" by simp
qed
thus ?thesis by simp
qed
lemma dgrad_p_set_closed_monom_mult:
assumes "dickson_grading d" and "d t ≤ m" and "p ∈ dgrad_p_set d m"
shows "monom_mult c t p ∈ dgrad_p_set d m"
proof (rule dgrad_p_setI)
fix v
assume "v ∈ keys (monom_mult c t p)"
hence "pp_of_term v ∈ pp_of_term ` keys (monom_mult c t p)" by simp
with dgrad_set_le_monom_mult[OF assms(1)] obtain s where "s ∈ insert t (pp_of_term ` keys p)"
and "d (pp_of_term v) ≤ d s" by (rule dgrad_set_leE)
from this(1) have "s = t ∨ s ∈ pp_of_term ` keys p" by simp
thus "d (pp_of_term v) ≤ m"
proof
assume "s = t"
with ‹d (pp_of_term v) ≤ d s› assms(2) show ?thesis by simp
next
assume "s ∈ pp_of_term ` keys p"
then obtain u where "u ∈ keys p" and "s = pp_of_term u" ..
from assms(3) this(1) have "d s ≤ m" unfolding ‹s = pp_of_term u› by (rule dgrad_p_setD)
with ‹d (pp_of_term v) ≤ d s› show ?thesis by (rule le_trans)
qed
qed
lemma dgrad_p_set_closed_monom_mult_zero:
assumes "p ∈ dgrad_p_set d m"
shows "monom_mult c 0 p ∈ dgrad_p_set d m"
proof (rule dgrad_p_setI)
fix v
assume "v ∈ keys (monom_mult c 0 p)"
hence "pp_of_term v ∈ pp_of_term ` keys (monom_mult c 0 p)" by simp
then obtain u where "u ∈ keys (monom_mult c 0 p)" and eq: "pp_of_term v = pp_of_term u" ..
from this(1) have "u ∈ keys p" by (metis keys_monom_multE splus_zero)
with assms have "d (pp_of_term u) ≤ m" by (rule dgrad_p_setD)
thus "d (pp_of_term v) ≤ m" by (simp only: eq)
qed
lemma dgrad_p_set_closed_except:
assumes "p ∈ dgrad_p_set d m"
shows "except p S ∈ dgrad_p_set d m"
by (rule dgrad_p_setI, rule dgrad_p_setD, rule assms, simp add: keys_except)
lemma dgrad_p_set_closed_tail:
assumes "p ∈ dgrad_p_set d m"
shows "tail p ∈ dgrad_p_set d m"
unfolding tail_def lower_def using assms by (rule dgrad_p_set_closed_except)
subsection ‹Dickson's Lemma for Sequences of Terms›
lemma Dickson_term:
assumes "dickson_grading d" and "finite K"
shows "almost_full_on (adds⇩t) {t. pp_of_term t ∈ dgrad_set d m ∧ component_of_term t ∈ K}"
(is "almost_full_on _ ?A")
proof (rule almost_full_onI)
fix seq :: "nat ⇒ 't"
assume *: "∀i. seq i ∈ ?A"
define seq' where "seq' = (λi. (pp_of_term (seq i), component_of_term (seq i)))"
have "pp_of_term ` ?A ⊆ {x. d x ≤ m}" by (auto dest: dgrad_setD)
moreover from assms(1) have "almost_full_on (adds) {x. d x ≤ m}" by (rule dickson_gradingD2)
ultimately have "almost_full_on (adds) (pp_of_term ` ?A)" by (rule almost_full_on_subset)
moreover have "almost_full_on (=) (component_of_term ` ?A)"
proof (rule eq_almost_full_on_finite_set)
have "component_of_term ` ?A ⊆ K" by blast
thus "finite (component_of_term ` ?A)" using assms(2) by (rule finite_subset)
qed
ultimately have "almost_full_on (prod_le (adds) (=)) (pp_of_term ` ?A × component_of_term ` ?A)"
by (rule almost_full_on_Sigma)
moreover from * have "⋀i. seq' i ∈ pp_of_term ` ?A × component_of_term ` ?A" by (simp add: seq'_def)
ultimately obtain i j where "i < j" and "prod_le (adds) (=) (seq' i) (seq' j)"
by (rule almost_full_onD)
from this(2) have "seq i adds⇩t seq j" by (simp add: seq'_def prod_le_def adds_term_def)
with ‹i < j› show "good (adds⇩t) seq" by (rule goodI)
qed
corollary Dickson_termE:
assumes "dickson_grading d" and "finite (component_of_term ` range (f::nat ⇒ 't))"
and "pp_of_term ` range f ⊆ dgrad_set d m"
obtains i j where "i < j" and "f i adds⇩t f j"
proof -
let ?A = "{t. pp_of_term t ∈ dgrad_set d m ∧ component_of_term t ∈ component_of_term ` range f}"
from assms(1, 2) have "almost_full_on (adds⇩t) ?A" by (rule Dickson_term)
moreover from assms(3) have "⋀i. f i ∈ ?A" by blast
ultimately obtain i j where "i < j" and "f i adds⇩t f j" by (rule almost_full_onD)
thus ?thesis ..
qed
lemma ex_finite_adds_term:
assumes "dickson_grading d" and "finite (component_of_term ` S)" and "pp_of_term ` S ⊆ dgrad_set d m"
obtains T where "finite T" and "T ⊆ S" and "⋀s. s ∈ S ⟹ (∃t∈T. t adds⇩t s)"
proof -
let ?A = "{t. pp_of_term t ∈ dgrad_set d m ∧ component_of_term t ∈ component_of_term ` S}"
have "reflp ((adds⇩t)::'t ⇒ _)" by (simp add: reflp_def adds_term_refl)
moreover have "almost_full_on (adds⇩t) S"
proof (rule almost_full_on_subset)
from assms(3) show "S ⊆ ?A" by blast
next
from assms(1, 2) show "almost_full_on (adds⇩t) ?A" by (rule Dickson_term)
qed
ultimately obtain T where "finite T" and "T ⊆ S" and "⋀s. s ∈ S ⟹ (∃t∈T. t adds⇩t s)"
by (rule almost_full_on_finite_subsetE, blast)
thus ?thesis ..
qed
subsection ‹Well-foundedness›
definition dickson_less_v :: "('a ⇒ nat) ⇒ nat ⇒ 't ⇒ 't ⇒ bool"
where "dickson_less_v d m v u ⟷ (d (pp_of_term v) ≤ m ∧ d (pp_of_term u) ≤ m ∧ v ≺⇩t u)"
definition dickson_less_p :: "('a ⇒ nat) ⇒ nat ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::zero) ⇒ bool"
where "dickson_less_p d m p q ⟷ ({p, q} ⊆ dgrad_p_set d m ∧ p ≺⇩p q)"
lemma dickson_less_vI:
assumes "d (pp_of_term v) ≤ m" and "d (pp_of_term u) ≤ m" and "v ≺⇩t u"
shows "dickson_less_v d m v u"
using assms by (simp add: dickson_less_v_def)
lemma dickson_less_vD1:
assumes "dickson_less_v d m v u"
shows "d (pp_of_term v) ≤ m"
using assms by (simp add: dickson_less_v_def)
lemma dickson_less_vD2:
assumes "dickson_less_v d m v u"
shows "d (pp_of_term u) ≤ m"
using assms by (simp add: dickson_less_v_def)
lemma dickson_less_vD3:
assumes "dickson_less_v d m v u"
shows "v ≺⇩t u"
using assms by (simp add: dickson_less_v_def)
lemma dickson_less_v_irrefl: "¬ dickson_less_v d m v v"
by (simp add: dickson_less_v_def)
lemma dickson_less_v_trans:
assumes "dickson_less_v d m v u" and "dickson_less_v d m u w"
shows "dickson_less_v d m v w"
using assms by (auto simp add: dickson_less_v_def)
lemma wf_dickson_less_v_aux1:
assumes "dickson_grading d" and "⋀i::nat. dickson_less_v d m (seq (Suc i)) (seq i)"
obtains i where "⋀j. j > i ⟹ component_of_term (seq j) < component_of_term (seq i)"
proof -
let ?Q = "pp_of_term ` range seq"
have "pp_of_term (seq 0) ∈ ?Q" by simp
with wf_dickson_less[OF assms(1)] obtain t where "t ∈ ?Q" and *: "⋀s. dickson_less d m s t ⟹ s ∉ ?Q"
by (rule wfE_min[to_pred], blast)
from this(1) obtain i where t: "t = pp_of_term (seq i)" by fastforce
show ?thesis
proof
fix j
assume "i < j"
with _ assms(2) have dlv: "dickson_less_v d m (seq j) (seq i)"
proof (rule transp_sequence)
from dickson_less_v_trans show "transp (dickson_less_v d m)" by (rule transpI)
qed
hence "seq j ≺⇩t seq i" by (rule dickson_less_vD3)
define s where "s = pp_of_term (seq j)"
have "pp_of_term (seq j) ∈ ?Q" by simp
hence "¬ dickson_less d m s t" unfolding s_def using * by blast
moreover from dlv have "d s ≤ m" and "d t ≤ m" unfolding s_def t
by (rule dickson_less_vD1, rule dickson_less_vD2)
ultimately have "t ≼ s" by (simp add: dickson_less_def)
show "component_of_term (seq j) < component_of_term (seq i)"
proof (rule ccontr, simp only: not_less)
assume "component_of_term (seq i) ≤ component_of_term (seq j)"
with ‹t ≼ s› have "seq i ≼⇩t seq j" unfolding s_def t by (rule ord_termI)
moreover from dlv have "seq j ≺⇩t seq i" by (rule dickson_less_vD3)
ultimately show False by simp
qed
qed
qed
lemma wf_dickson_less_v_aux2:
assumes "dickson_grading d" and "⋀i::nat. dickson_less_v d m (seq (Suc i)) (seq i)"
and "⋀i::nat. component_of_term (seq i) < k"
shows thesis
using assms(2, 3)
proof (induct k arbitrary: seq thesis rule: less_induct)
case (less k)
from assms(1) less(2) obtain i where *: "⋀j. j > i ⟹ component_of_term (seq j) < component_of_term (seq i)"
by (rule wf_dickson_less_v_aux1, blast)
define seq1 where "seq1 = (λj. seq (Suc (i + j)))"
from less(3) show ?case
proof (rule less(1))
fix j
show "dickson_less_v d m (seq1 (Suc j)) (seq1 j)" by (simp add: seq1_def, fact less(2))
next
fix j
show "component_of_term (seq1 j) < component_of_term (seq i)" by (simp add: seq1_def *)
qed
qed
lemma wf_dickson_less_v:
assumes "dickson_grading d"
shows "wfP (dickson_less_v d m)"
proof (rule wfP_chain, rule, elim exE)
fix seq::"nat ⇒ 't"
assume "∀i. dickson_less_v d m (seq (Suc i)) (seq i)"
hence *: "⋀i. dickson_less_v d m (seq (Suc i)) (seq i)" ..
with assms obtain i where **: "⋀j. j > i ⟹ component_of_term (seq j) < component_of_term (seq i)"
by (rule wf_dickson_less_v_aux1, blast)
define seq1 where "seq1 = (λj. seq (Suc (i + j)))"
from assms show False
proof (rule wf_dickson_less_v_aux2)
fix j
show "dickson_less_v d m (seq1 (Suc j)) (seq1 j)" by (simp add: seq1_def, fact *)
next
fix j
show "component_of_term (seq1 j) < component_of_term (seq i)" by (simp add: seq1_def **)
qed
qed
lemma dickson_less_v_zero: "dickson_less_v (λ_. 0) m = (≺⇩t)"
by (rule, rule, simp add: dickson_less_v_def)
lemma dickson_less_pI:
assumes "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m" and "p ≺⇩p q"
shows "dickson_less_p d m p q"
using assms by (simp add: dickson_less_p_def)
lemma dickson_less_pD1:
assumes "dickson_less_p d m p q"
shows "p ∈ dgrad_p_set d m"
using assms by (simp add: dickson_less_p_def)
lemma dickson_less_pD2:
assumes "dickson_less_p d m p q"
shows "q ∈ dgrad_p_set d m"
using assms by (simp add: dickson_less_p_def)
lemma dickson_less_pD3:
assumes "dickson_less_p d m p q"
shows "p ≺⇩p q"
using assms by (simp add: dickson_less_p_def)
lemma dickson_less_p_irrefl: "¬ dickson_less_p d m p p"
by (simp add: dickson_less_p_def)
lemma dickson_less_p_trans:
assumes "dickson_less_p d m p q" and "dickson_less_p d m q r"
shows "dickson_less_p d m p r"
using assms by (auto simp add: dickson_less_p_def)
lemma dickson_less_p_mono:
assumes "dickson_less_p d m p q" and "m ≤ n"
shows "dickson_less_p d n p q"
proof -
from assms(2) have "dgrad_p_set d m ⊆ dgrad_p_set d n" by (rule dgrad_p_set_subset)
moreover from assms(1) have "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m" and "p ≺⇩p q"
by (rule dickson_less_pD1, rule dickson_less_pD2, rule dickson_less_pD3)
ultimately have "p ∈ dgrad_p_set d n" and "q ∈ dgrad_p_set d n" by auto
from this ‹p ≺⇩p q› show ?thesis by (rule dickson_less_pI)
qed
lemma dickson_less_p_zero: "dickson_less_p (λ_. 0) m = (≺⇩p)"
by (rule, rule, simp add: dickson_less_p_def)
lemma wf_dickson_less_p_aux:
assumes "dickson_grading d"
assumes "x ∈ Q" and "∀y∈Q. y ≠ 0 ⟶ (y ∈ dgrad_p_set d m ∧ dickson_less_v d m (lt y) u)"
shows "∃p∈Q. (∀q∈Q. ¬ dickson_less_p d m q p)"
using assms(2) assms(3)
proof (induct u arbitrary: x Q rule: wfP_induct[OF wf_dickson_less_v, OF assms(1)])
fix u::'t and x::"'t ⇒⇩0 'b" and Q::"('t ⇒⇩0 'b) set"
assume hyp: "∀u0. dickson_less_v d m u0 u ⟶ (∀x0 Q0::('t ⇒⇩0 'b) set. x0 ∈ Q0 ⟶
(∀y∈Q0. y ≠ 0 ⟶ (y ∈ dgrad_p_set d m ∧ dickson_less_v d m (lt y) u0)) ⟶
(∃p∈Q0. ∀q∈Q0. ¬ dickson_less_p d m q p))"
assume "x ∈ Q"
assume "∀y∈Q. y ≠ 0 ⟶ (y ∈ dgrad_p_set d m ∧ dickson_less_v d m (lt y) u)"
hence bounded: "⋀y. y ∈ Q ⟹ y ≠ 0 ⟹ (y ∈ dgrad_p_set d m ∧ dickson_less_v d m (lt y) u)" by auto
show "∃p∈Q. ∀q∈Q. ¬ dickson_less_p d m q p"
proof (cases "0 ∈ Q")
case True
show ?thesis
proof (rule, rule, rule)
fix q::"'t ⇒⇩0 'b"
assume "dickson_less_p d m q 0"
hence "q ≺⇩p 0" by (rule dickson_less_pD3)
thus False using ord_p_zero_min[of q] by simp
next
from True show "0 ∈ Q" .
qed
next
case False
define Q1 where "Q1 = {lt p | p. p ∈ Q}"
from ‹x ∈ Q› have "lt x ∈ Q1" unfolding Q1_def by auto
with wf_dickson_less_v[OF assms(1)] obtain v
where "v ∈ Q1" and v_min_1: "⋀q. dickson_less_v d m q v ⟹ q ∉ Q1"
by (rule wfE_min[to_pred], auto)
have v_min: "⋀q. q ∈ Q ⟹ ¬ dickson_less_v d m (lt q) v"
proof -
fix q
assume "q ∈ Q"
hence "lt q ∈ Q1" unfolding Q1_def by auto
thus "¬ dickson_less_v d m (lt q) v" using v_min_1 by auto
qed
from ‹v ∈ Q1› obtain p where "lt p = v" and "p ∈ Q" unfolding Q1_def by auto
hence "p ≠ 0" using False by auto
with ‹p ∈ Q› have "p ∈ dgrad_p_set d m ∧ dickson_less_v d m (lt p) u" by (rule bounded)
hence "p ∈ dgrad_p_set d m" and "dickson_less_v d m (lt p) u" by simp_all
moreover from this(1) ‹p ≠ 0› have "d (pp_of_term (lt p)) ≤ m" by (rule dgrad_p_setD_lp)
ultimately have "d (pp_of_term v) ≤ m" by (simp only: ‹lt p = v›)
define Q2 where "Q2 = {tail p | p. p ∈ Q ∧ lt p = v}"
from ‹p ∈ Q› ‹lt p = v› have "tail p ∈ Q2" unfolding Q2_def by auto
have "∀q∈Q2. q ≠ 0 ⟶ (q ∈ dgrad_p_set d m ∧ dickson_less_v d m (lt q) (lt p))"
proof (intro ballI impI)
fix q
assume "q ∈ Q2"
then obtain q0 where q: "q = tail q0" and "lt q0 = lt p" and "q0 ∈ Q"
using ‹lt p = v› by (auto simp add: Q2_def)
assume "q ≠ 0"
hence "tail q0 ≠ 0" using ‹q = tail q0› by simp
hence "q0 ≠ 0" by auto
with ‹q0 ∈ Q› have "q0 ∈ dgrad_p_set d m ∧ dickson_less_v d m (lt q0) u" by (rule bounded)
hence "q0 ∈ dgrad_p_set d m" and "dickson_less_v d m (lt q0) u" by simp_all
from this(1) have "q ∈ dgrad_p_set d m" unfolding q by (rule dgrad_p_set_closed_tail)
show "q ∈ dgrad_p_set d m ∧ dickson_less_v d m (lt q) (lt p)"
proof
show "dickson_less_v d m (lt q) (lt p)"
proof (rule dickson_less_vI)
from ‹q ∈ dgrad_p_set d m› ‹q ≠ 0› show "d (pp_of_term (lt q)) ≤ m" by (rule dgrad_p_setD_lp)
next
from ‹dickson_less_v d m (lt p) u› show "d (pp_of_term (lt p)) ≤ m" by (rule dickson_less_vD1)
next
from lt_tail[OF ‹tail q0 ≠ 0›] ‹q = tail q0› ‹lt q0 = lt p› show "lt q ≺⇩t lt p" by simp
qed
qed fact
qed
with hyp ‹dickson_less_v d m (lt p) u› ‹tail p ∈ Q2› have "∃p∈Q2. ∀q∈Q2. ¬ dickson_less_p d m q p"
by blast
then obtain q where "q ∈ Q2" and q_min: "∀r∈Q2. ¬ dickson_less_p d m r q" ..
from ‹q ∈ Q2› obtain q0 where "q = tail q0" and "q0 ∈ Q" and "lt q0 = v" unfolding Q2_def by auto
from q_min ‹q = tail q0› have q0_tail_min: "⋀r. r ∈ Q2 ⟹ ¬ dickson_less_p d m r (tail q0)" by simp
from ‹q0 ∈ Q› show ?thesis
proof
show "∀r∈Q. ¬ dickson_less_p d m r q0"
proof (intro ballI notI)
fix r
assume "dickson_less_p d m r q0"
hence "r ∈ dgrad_p_set d m" and "q0 ∈ dgrad_p_set d m" and "r ≺⇩p q0"
by (rule dickson_less_pD1, rule dickson_less_pD2, rule dickson_less_pD3)
from this(3) have "lt r ≼⇩t lt q0" by (simp add: ord_p_lt)
with ‹lt q0 = v› have "lt r ≼⇩t v" by simp
assume "r ∈ Q"
hence "¬ dickson_less_v d m (lt r) v" by (rule v_min)
from False ‹r ∈ Q› have "r ≠ 0" using False by blast
with ‹r ∈ dgrad_p_set d m› have "d (pp_of_term (lt r)) ≤ m" by (rule dgrad_p_setD_lp)
have "¬ lt r ≺⇩t v"
proof
assume "lt r ≺⇩t v"
with ‹d (pp_of_term (lt r)) ≤ m› ‹d (pp_of_term v) ≤ m› have "dickson_less_v d m (lt r) v"
by (rule dickson_less_vI)
with ‹¬ dickson_less_v d m (lt r) v› show False ..
qed
with ‹lt r ≼⇩t v› have "lt r = v" by simp
with ‹r ∈ Q› have "tail r ∈ Q2" by (auto simp add: Q2_def)
have "dickson_less_p d m (tail r) (tail q0)"
proof (rule dickson_less_pI)
show "tail r ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_tail, fact)
next
show "tail q0 ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_tail, fact)
next
have "lt r = lt q0" by (simp only: ‹lt r = v› ‹lt q0 = v›)
from ‹r ≠ 0› this ‹r ≺⇩p q0› show "tail r ≺⇩p tail q0" by (rule ord_p_tail)
qed
with q0_tail_min[OF ‹tail r ∈ Q2›] show False ..
qed
qed
qed
qed
theorem wf_dickson_less_p:
assumes "dickson_grading d"
shows "wfP (dickson_less_p d m)"
proof (rule wfI_min[to_pred])
fix Q::"('t ⇒⇩0 'b) set" and x
assume "x ∈ Q"
show "∃z∈Q. ∀y. dickson_less_p d m y z ⟶ y ∉ Q"
proof (cases "0 ∈ Q")
case True
show ?thesis
proof (rule, rule, rule)
from True show "0 ∈ Q" .
next
fix q::"'t ⇒⇩0 'b"
assume "dickson_less_p d m q 0"
hence "q ≺⇩p 0" by (rule dickson_less_pD3)
thus "q ∉ Q" using ord_p_zero_min[of q] by simp
qed
next
case False
show ?thesis
proof (cases "Q ⊆ dgrad_p_set d m")
case True
let ?L = "lt ` Q"
from ‹x ∈ Q› have "lt x ∈ ?L" by simp
with wf_dickson_less_v[OF assms] obtain v where "v ∈ ?L"
and v_min: "⋀u. dickson_less_v d m u v ⟹ u ∉ ?L" by (rule wfE_min[to_pred], blast)
from this(1) obtain x1 where "x1 ∈ Q" and "v = lt x1" ..
from this(1) True False have "x1 ∈ dgrad_p_set d m" and "x1 ≠ 0" by auto
hence "d (pp_of_term v) ≤ m" unfolding ‹v = lt x1› by (rule dgrad_p_setD_lp)
define Q1 where "Q1 = {tail p | p. p ∈ Q ∧ lt p = v}"
from ‹x1 ∈ Q› have "tail x1 ∈ Q1" by (auto simp add: Q1_def ‹v = lt x1›)
with assms have "∃p∈Q1. ∀q∈Q1. ¬ dickson_less_p d m q p"
proof (rule wf_dickson_less_p_aux)
show "∀y∈Q1. y ≠ 0 ⟶ y ∈ dgrad_p_set d m ∧ dickson_less_v d m (lt y) v"
proof (intro ballI impI)
fix y
assume "y ∈ Q1" and "y ≠ 0"
from this(1) obtain y1 where "y1 ∈ Q" and "v = lt y1" and "y = tail y1" unfolding Q1_def
by blast
from this(1) True have "y1 ∈ dgrad_p_set d m" ..
hence "y ∈ dgrad_p_set d m" unfolding ‹y = tail y1› by (rule dgrad_p_set_closed_tail)
thus "y ∈ dgrad_p_set d m ∧ dickson_less_v d m (lt y) v"
proof
show "dickson_less_v d m (lt y) v"
proof (rule dickson_less_vI)
from ‹y ∈ dgrad_p_set d m› ‹y ≠ 0› show "d (pp_of_term (lt y)) ≤ m"
by (rule dgrad_p_setD_lp)
next
from ‹y ≠ 0› show "lt y ≺⇩t v" unfolding ‹v = lt y1› ‹y = tail y1› by (rule lt_tail)
qed fact
qed
qed
qed
then obtain p0 where "p0 ∈ Q1" and p0_min: "⋀q. q ∈ Q1 ⟹ ¬ dickson_less_p d m q p0" by blast
from this(1) obtain p where "p ∈ Q" and "v = lt p" and "p0 = tail p" unfolding Q1_def
by blast
from this(1) False have "p ≠ 0" by blast
show ?thesis
proof (intro bexI allI impI notI)
fix y
assume "y ∈ Q"
hence "y ≠ 0" using False by blast
assume "dickson_less_p d m y p"
hence "y ∈ dgrad_p_set d m" and "p ∈ dgrad_p_set d m" and "y ≺⇩p p"
by (rule dickson_less_pD1, rule dickson_less_pD2, rule dickson_less_pD3)
from this(3) have "y ≼⇩p p" by simp
hence "lt y ≼⇩t lt p" by (rule ord_p_lt)
moreover have "¬ lt y ≺⇩t lt p"
proof
assume "lt y ≺⇩t lt p"
have "dickson_less_v d m (lt y) v" unfolding ‹v = lt p›
by (rule dickson_less_vI, rule dgrad_p_setD_lp, fact+, rule dgrad_p_setD_lp, fact+)
hence "lt y ∉ ?L" by (rule v_min)
hence "y ∉ Q" by fastforce
from this ‹y ∈ Q› show False ..
qed
ultimately have "lt y = lt p" by simp
from ‹y ≠ 0› this ‹y ≺⇩p p› have "tail y ≺⇩p tail p" by (rule ord_p_tail)
from ‹y ∈ Q› have "tail y ∈ Q1" by (auto simp add: Q1_def ‹v = lt p› ‹lt y = lt p›[symmetric])
hence "¬ dickson_less_p d m (tail y) p0" by (rule p0_min)
moreover have "dickson_less_p d m (tail y) p0" unfolding ‹p0 = tail p›
by (rule dickson_less_pI, rule dgrad_p_set_closed_tail, fact, rule dgrad_p_set_closed_tail, fact+)
ultimately show False ..
qed fact
next
case False
then obtain q where "q ∈ Q" and "q ∉ dgrad_p_set d m" by blast
from this(1) show ?thesis
proof
show "∀y. dickson_less_p d m y q ⟶ y ∉ Q"
proof (intro allI impI)
fix y
assume "dickson_less_p d m y q"
hence "q ∈ dgrad_p_set d m" by (rule dickson_less_pD2)
with ‹q ∉ dgrad_p_set d m› show "y ∉ Q" ..
qed
qed
qed
qed
qed
corollary ord_p_minimum_dgrad_p_set:
assumes "dickson_grading d" and "x ∈ Q" and "Q ⊆ dgrad_p_set d m"
obtains q where "q ∈ Q" and "⋀y. y ≺⇩p q ⟹ y ∉ Q"
proof -
from assms(1) have "wfP (dickson_less_p d m)" by (rule wf_dickson_less_p)
from this assms(2) obtain q where "q ∈ Q" and *: "⋀y. dickson_less_p d m y q ⟹ y ∉ Q"
by (rule wfE_min[to_pred], auto)
from assms(3) ‹q ∈ Q› have "q ∈ dgrad_p_set d m" ..
from ‹q ∈ Q› show ?thesis
proof
fix y
assume "y ≺⇩p q"
show "y ∉ Q"
proof
assume "y ∈ Q"
with assms(3) have "y ∈ dgrad_p_set d m" ..
from this ‹q ∈ dgrad_p_set d m› ‹y ≺⇩p q› have "dickson_less_p d m y q"
by (rule dickson_less_pI)
hence "y ∉ Q" by (rule *)
from this ‹y ∈ Q› show False ..
qed
qed
qed
lemma ord_term_minimum_dgrad_set:
assumes "dickson_grading d" and "v ∈ V" and "pp_of_term ` V ⊆ dgrad_set d m"
obtains u where "u ∈ V" and "⋀w. w ≺⇩t u ⟹ w ∉ V"
proof -
from assms(1) have "wfP (dickson_less_v d m)" by (rule wf_dickson_less_v)
then obtain u where "u ∈ V" and *: "⋀w. dickson_less_v d m w u ⟹ w ∉ V" using assms(2)
by (rule wfE_min[to_pred]) blast
from this(1) have "pp_of_term u ∈ pp_of_term ` V" by (rule imageI)
with assms(3) have "pp_of_term u ∈ dgrad_set d m" ..
hence "d (pp_of_term u) ≤ m" by (rule dgrad_setD)
from ‹u ∈ V› show ?thesis
proof
fix w
assume "w ≺⇩t u"
show "w ∉ V"
proof
assume "w ∈ V"
hence "pp_of_term w ∈ pp_of_term ` V" by (rule imageI)
with assms(3) have "pp_of_term w ∈ dgrad_set d m" ..
hence "d (pp_of_term w) ≤ m" by (rule dgrad_setD)
from this ‹d (pp_of_term u) ≤ m› ‹w ≺⇩t u› have "dickson_less_v d m w u"
by (rule dickson_less_vI)
hence "w ∉ V" by (rule *)
from this ‹w ∈ V› show False ..
qed
qed
qed
end
subsection ‹More Interpretations›
context gd_powerprod
begin
sublocale punit: gd_term to_pair_unit fst "(≼)" "(≺)" "(≼)" "(≺)" ..
end
locale od_term =
ordered_term pair_of_term term_of_pair ord ord_strict ord_term ord_term_strict
for pair_of_term::"'t ⇒ ('a::dickson_powerprod × 'k::{the_min,wellorder})"
and term_of_pair::"('a × 'k) ⇒ 't"
and ord::"'a ⇒ 'a ⇒ bool" (infixl "≼" 50)
and ord_strict (infixl "≺" 50)
and ord_term::"'t ⇒ 't ⇒ bool" (infixl "≼⇩t" 50)
and ord_term_strict::"'t ⇒ 't ⇒ bool" (infixl "≺⇩t" 50)
begin
sublocale gd_term ..
lemma ord_p_wf: "wfP (≺⇩p)"
proof -
from dickson_grading_zero have "wfP (dickson_less_p (λ_. 0) 0)" by (rule wf_dickson_less_p)
thus ?thesis by (simp only: dickson_less_p_zero)
qed
end
end
Theory Poly_Mapping_Finite_Map
theory Poly_Mapping_Finite_Map
imports
"More_MPoly_Type"
"HOL-Library.Finite_Map"
begin
subsection ‹TODO: move!›
lemma fmdom'_fmap_of_list: "fmdom' (fmap_of_list xs) = set (map fst xs)"
by (auto simp: fmdom'_def fmdom'I fmap_of_list.rep_eq weak_map_of_SomeI)
(metis map_of_eq_None_iff option.distinct(1))
text ‹In this theory, type @{typ "('a, 'b) poly_mapping"} is represented as association lists.
Code equations are proved in order actually perform computations (addition, multiplication, etc.).›
subsection ‹Utilities›
instantiation poly_mapping :: (type, "{equal, zero}") equal
begin
definition equal_poly_mapping::"('a, 'b) poly_mapping ⇒ ('a, 'b) poly_mapping ⇒ bool" where
"equal_poly_mapping p q ≡ (∀t. lookup p t = lookup q t)"
instance by standard (auto simp add: equal_poly_mapping_def poly_mapping_eqI)
end
definition "clearjunk0 m = fmfilter (λk. fmlookup m k ≠ Some 0) m"
definition "fmlookup_default d m x = (case fmlookup m x of Some v ⇒ v | None ⇒ d)"
abbreviation "lookup0 ≡ fmlookup_default 0"
lemma fmlookup_default_fmmap:
"fmlookup_default d (fmmap f M) x = (if x ∈ fmdom' M then f (fmlookup_default d M x) else d)"
by (auto simp: fmlookup_default_def fmdom'_notI split: option.splits)
lemma fmlookup_default_fmmap_keys: "fmlookup_default d (fmmap_keys f M) x =
(if x ∈ fmdom' M then f x (fmlookup_default d M x) else d)"
by (auto simp: fmlookup_default_def fmdom'_notI split: option.splits)
lemma fmlookup_default_add[simp]:
"fmlookup_default d (m ++⇩f n) x =
(if x |∈| fmdom n then the (fmlookup n x)
else fmlookup_default d m x)"
by (auto simp: fmlookup_default_def)
lemma fmlookup_default_if[simp]:
"fmlookup ys a = Some r ⟹ fmlookup_default d ys a = r"
"fmlookup ys a = None ⟹ fmlookup_default d ys a = d"
by (auto simp: fmlookup_default_def)
lemma finite_lookup_default:
"finite {x. fmlookup_default d xs x ≠ d}"
proof -
have "{x. fmlookup_default d xs x ≠ d} ⊆ fmdom' xs"
by (auto simp: fmlookup_default_def fmdom'I split: option.splits)
also have "finite …"
by simp
finally (finite_subset) show ?thesis .
qed
lemma lookup0_clearjunk0: "lookup0 xs s = lookup0 (clearjunk0 xs) s"
unfolding clearjunk0_def fmlookup_default_def
by auto
lemma clearjunk0_nonzero:
assumes "t ∈ fmdom' (clearjunk0 xs)"
shows "fmlookup xs t ≠ Some 0"
using assms unfolding clearjunk0_def by simp
lemma clearjunk0_map_of_SomeD:
assumes a1: "fmlookup xs t = Some c" and "c ≠ 0"
shows "t ∈ fmdom' (clearjunk0 xs)"
using assms
by (auto simp: clearjunk0_def fmdom'I)
subsection ‹Implementation of Polynomial Mappings as Association Lists›
lift_definition Pm_fmap::"('a, 'b::zero) fmap ⇒ 'a ⇒⇩0 'b" is lookup0
by (rule finite_lookup_default)
lemmas [simp] = Pm_fmap.rep_eq
code_datatype Pm_fmap
lemma PM_clearjunk0_cong:
"Pm_fmap (clearjunk0 xs) = Pm_fmap xs"
by (metis Pm_fmap.rep_eq lookup0_clearjunk0 poly_mapping_eqI)
lemma PM_all_2:
assumes "P 0 0"
shows "(∀x. P (lookup (Pm_fmap xs) x) (lookup (Pm_fmap ys) x)) =
fmpred (λk v. P (lookup0 xs k) (lookup0 ys k)) (xs ++⇩f ys)"
using assms unfolding list_all_def
by (force simp: fmlookup_default_def fmlookup_dom_iff
split: option.splits if_splits)
lemma compute_keys_pp[code]: "keys (Pm_fmap xs) = fmdom' (clearjunk0 xs)"
by transfer
(auto simp: fmlookup_dom'_iff clearjunk0_def fmlookup_default_def fmdom'I split: option.splits)
lemma compute_zero_pp[code]: "0 = Pm_fmap fmempty"
by (auto intro!: poly_mapping_eqI simp: fmlookup_default_def)
lemma compute_plus_pp [code]:
"Pm_fmap xs + Pm_fmap ys = Pm_fmap (clearjunk0 (fmmap_keys (λk v. lookup0 xs k + lookup0 ys k) (xs ++⇩f ys)))"
by (auto intro!: poly_mapping_eqI
simp: fmlookup_default_def lookup_add fmlookup_dom_iff PM_clearjunk0_cong
split: option.splits)
lemma compute_lookup_pp[code]:
"lookup (Pm_fmap xs) x = lookup0 xs x"
by (transfer, simp)
lemma compute_minus_pp [code]:
"Pm_fmap xs - Pm_fmap ys = Pm_fmap (clearjunk0 (fmmap_keys (λk v. lookup0 xs k - lookup0 ys k) (xs ++⇩f ys)))"
by (auto intro!: poly_mapping_eqI
simp: fmlookup_default_def lookup_minus fmlookup_dom_iff PM_clearjunk0_cong
split: option.splits)
lemma compute_uminus_pp[code]:
"- Pm_fmap ys = Pm_fmap (fmmap_keys (λk v. - lookup0 ys k) ys)"
by (auto intro!: poly_mapping_eqI
simp: fmlookup_default_def
split: option.splits)
lemma compute_equal_pp[code]:
"equal_class.equal (Pm_fmap xs) (Pm_fmap ys) = fmpred (λk v. lookup0 xs k = lookup0 ys k) (xs ++⇩f ys)"
unfolding equal_poly_mapping_def by (simp only: PM_all_2)
lemma compute_map_pp[code]:
"Poly_Mapping.map f (Pm_fmap xs) = Pm_fmap (fmmap (λx. f x when x ≠ 0) xs)"
by (auto intro!: poly_mapping_eqI
simp: fmlookup_default_def map.rep_eq
split: option.splits)
lemma fmran'_fmfilter_eq: "fmran' (fmfilter p fm) = {y | y. ∃x ∈ fmdom' fm. p x ∧ fmlookup fm x = Some y}"
by (force simp: fmlookup_ran'_iff fmdom'I split: if_splits)
lemma compute_range_pp[code]:
"Poly_Mapping.range (Pm_fmap xs) = fmran' (clearjunk0 xs)"
by (force simp: range.rep_eq clearjunk0_def fmran'_fmfilter_eq fmdom'I
fmlookup_default_def split: option.splits)
subsubsection ‹Constructors›
definition "sparse⇩0 xs = Pm_fmap (fmap_of_list xs)"
definition "dense⇩0 xs = Pm_fmap (fmap_of_list (zip [0..<length xs] xs))"
lemma compute_single[code]: "Poly_Mapping.single k v = sparse⇩0 [(k, v)]"
by (auto simp: sparse⇩0_def fmlookup_default_def lookup_single intro!: poly_mapping_eqI )
end
Theory MPoly_Type_Class_FMap
section ‹Executable Representation of Polynomial Mappings as Association Lists›
theory MPoly_Type_Class_FMap
imports
MPoly_Type_Class_Ordered
Poly_Mapping_Finite_Map
begin
text ‹In this theory, (type class) multivariate polynomials of type
@{typ "('a, 'b) poly_mapping"} are represented as association lists.›
text ‹It is important to note that theory ‹MPoly_Type_Class_OAlist›, which represents polynomials as
@{emph ‹ordered›} associative lists, is much better suited for doing actual computations. This
theory is only included for being able to compare the two representations in terms of efficiency.›
subsection ‹Power Products›
lemma compute_lcs_pp[code]:
"lcs (Pm_fmap xs) (Pm_fmap ys) =
Pm_fmap (fmmap_keys (λk v. Orderings.max (lookup0 xs k) (lookup0 ys k)) (xs ++⇩f ys))"
by (rule poly_mapping_eqI)
(auto simp add: fmlookup_default_fmmap_keys fmlookup_dom_iff fmdom'_notI
lcs_poly_mapping.rep_eq fmdom'_notD)
lemma compute_deg_pp[code]:
"deg_pm (Pm_fmap xs) = sum (the o fmlookup xs) (fmdom' xs)"
proof -
have "deg_pm (Pm_fmap xs) = sum (lookup (Pm_fmap xs)) (keys (Pm_fmap xs))"
by (rule deg_pm_superset) auto
also have "… = sum (the o fmlookup xs) (fmdom' xs)"
by (rule sum.mono_neutral_cong_left)
(auto simp: fmlookup_dom'_iff fmdom'I in_keys_iff fmlookup_default_def
split: option.splits)
finally show ?thesis .
qed
definition adds_pp_add_linorder :: "('b ⇒⇩0 'a::add_linorder) ⇒ _ ⇒ bool"
where [code_abbrev]: "adds_pp_add_linorder = (adds)"
lemma compute_adds_pp[code]:
"adds_pp_add_linorder (Pm_fmap xs) (Pm_fmap ys) =
(fmpred (λk v. lookup0 xs k ≤ lookup0 ys k) (xs ++⇩f ys))"
for xs ys::"('a, 'b::add_linorder_min) fmap"
unfolding adds_pp_add_linorder_def
unfolding adds_poly_mapping
using fmdom_notI
by (force simp: fmlookup_dom_iff le_fun_def
split: option.splits if_splits)
text‹Computing @{term lex} as below is certainly not the most efficient way, but it works.›
lemma lex_pm_iff: "lex_pm s t = (∀x. lookup s x ≤ lookup t x ∨ (∃y<x. lookup s y ≠ lookup t y))"
proof -
have "lex_pm s t = (¬ lex_pm_strict t s)" by (simp add: lex_pm_strict_alt)
also have "… = (∀x. lookup s x ≤ lookup t x ∨ (∃y<x. lookup s y ≠ lookup t y))"
by (simp add: lex_pm_strict_def less_poly_mapping_def less_fun_def) (metis leD leI)
finally show ?thesis .
qed
lemma compute_lex_pp[code]:
"(lex_pm (Pm_fmap xs) (Pm_fmap (ys::(_, _::ordered_comm_monoid_add) fmap))) =
(let zs = xs ++⇩f ys in
fmpred (λx v.
lookup0 xs x ≤ lookup0 ys x ∨
¬ fmpred (λy w. y ≥ x ∨ lookup0 xs y = lookup0 ys y) zs) zs
)"
unfolding Let_def lex_pm_iff fmpred_iff Pm_fmap.rep_eq fmlookup_add fmlookup_dom_iff
apply (intro iffI)
apply (metis fmdom'_notD fmlookup_default_if(2) fmlookup_dom'_iff leD)
apply (metis eq_iff not_le fmdom'_notD fmlookup_default_if(2) fmlookup_dom'_iff)
done
lemma compute_dord_pp[code]:
"(dord_pm ord (Pm_fmap xs) (Pm_fmap (ys::('a::wellorder , 'b::ordered_comm_monoid_add) fmap))) =
(let dx = deg_pm (Pm_fmap xs) in let dy = deg_pm (Pm_fmap ys) in
dx < dy ∨ (dx = dy ∧ ord (Pm_fmap xs) (Pm_fmap ys))
)"
by (auto simp: Let_def deg_pm.rep_eq dord_fun_def dord_pm.rep_eq)
(simp_all add: Pm_fmap.abs_eq)
subsubsection ‹Computations›
experiment begin
abbreviation "X ≡ 0::nat"
abbreviation "Y ≡ 1::nat"
abbreviation "Z ≡ 2::nat"
lemma
"sparse⇩0 [(X, 2::nat), (Z, 7)] + sparse⇩0 [(Y, 3), (Z, 2)] = sparse⇩0 [(X, 2), (Z, 9), (Y, 3)]"
"dense⇩0 [2, 0, 7::nat] + dense⇩0 [0, 3, 2] = dense⇩0 [2, 3, 9]"
by eval+
lemma
"sparse⇩0 [(X, 2::nat), (Z, 7)] - sparse⇩0 [(X, 2), (Z, 2)] = sparse⇩0 [(Z, 5)]"
by eval
lemma
"lcs (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 7)]) (sparse⇩0 [(Y, 3), (Z, 2)]) = sparse⇩0 [(X, 2), (Y, 3), (Z, 7)]"
by eval
lemma
"(sparse⇩0 [(X, 2::nat), (Z, 1)]) adds (sparse⇩0 [(X, 3), (Y, 2), (Z, 1)])"
by eval
lemma
"lookup (sparse⇩0 [(X, 2::nat), (Z, 3)]) X = 2"
by eval
lemma
"deg_pm (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 3), (X, 1)]) = 6"
by eval
lemma
"lex_pm (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse⇩0 [(X, 4)])"
by eval
lemma
"lex_pm (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse⇩0 [(X, 4)])"
by eval
lemma
"¬ (dlex_pm (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse⇩0 [(X, 4)]))"
by eval
lemma
"dlex_pm (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse⇩0 [(X, 5)])"
by eval
lemma
"¬ (drlex_pm (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse⇩0 [(X, 5)]))"
by eval
end
subsection ‹Implementation of Multivariate Polynomials as Association Lists›
subsubsection ‹Unordered Power-Products›
lemma compute_monomial [code]:
"monomial c t = (if c = 0 then 0 else sparse⇩0 [(t, c)])"
by (auto intro!: poly_mapping_eqI simp: sparse⇩0_def fmlookup_default_def lookup_single)
lemma compute_one_poly_mapping [code]: "1 = sparse⇩0 [(0, 1)]"
by (metis compute_monomial single_one zero_neq_one)
lemma compute_except_poly_mapping [code]:
"except (Pm_fmap xs) S = Pm_fmap (fmfilter (λk. k ∉ S) xs)"
by (auto simp: fmlookup_default_def lookup_except split: option.splits intro!: poly_mapping_eqI)
lemma lookup0_fmap_of_list_simps:
"lookup0 (fmap_of_list ((x, y)#xs)) i = (if x = i then y else lookup0 (fmap_of_list xs) i)"
"lookup0 (fmap_of_list []) i = 0"
by (auto simp: fmlookup_default_def fmlookup_of_list split: if_splits option.splits)
lemma if_poly_mapping_eq_iff:
"(if x = y then a else b) =
(if (∀i∈keys x ∪ keys y. lookup x i = lookup y i) then a else b)"
by simp (metis UnI1 UnI2 in_keys_iff poly_mapping_eqI)
lemma keys_add_eq: "keys (a + b) = keys a ∪ keys b - {x ∈ keys a ∩ keys b. lookup a x + lookup b x = 0}"
by (auto simp: in_keys_iff lookup_add add_eq_0_iff)
context term_powerprod
begin
context includes fmap.lifting begin
lift_definition shift_keys::"'a ⇒ ('t, 'b) fmap ⇒ ('t, 'b) fmap"
is "λt m x. if t adds⇩p x then m (x ⊖ t) else None"
proof -
fix t and f::"'t ⇒ 'b option"
assume "finite (dom f)"
have "dom (λx. if t adds⇩p x then f (x ⊖ t) else None) ⊆ (⊕) t ` dom f"
by (auto simp: adds_pp_alt domI term_simps split: if_splits)
also have "finite …"
using ‹finite (dom f)› by simp
finally (finite_subset) show "finite (dom (λx. if t adds⇩p x then f (x ⊖ t) else None))" .
qed
definition "shift_map_keys t f m = fmmap f (shift_keys t m)"
lemma compute_shift_map_keys[code]:
"shift_map_keys t f (fmap_of_list xs) = fmap_of_list (map (λ(k, v). (t ⊕ k, f v)) xs)"
unfolding shift_map_keys_def
apply transfer
subgoal for f t xs
proof -
show ?thesis
apply (rule ext)
subgoal for x
apply (cases "t adds⇩p x")
subgoal by (induction xs) (auto simp: adds_pp_alt term_simps)
subgoal by (induction xs) (auto simp: adds_pp_alt term_simps)
done
done
qed
done
end
lemmas [simp] = compute_zero_pp[symmetric]
lemma compute_monom_mult_poly_mapping [code]:
"monom_mult c t (Pm_fmap xs) = Pm_fmap (if c = 0 then fmempty else shift_map_keys t ((*) c) xs)"
proof (cases "c = 0")
case True
hence "monom_mult c t (Pm_fmap xs) = 0" using monom_mult_zero_left by simp
thus ?thesis using True
by simp
next
case False
thus ?thesis
by (auto simp: simp: fmlookup_default_def shift_map_keys_def lookup_monom_mult
adds_def group_eq_aux shift_keys.rep_eq
intro!: poly_mapping_eqI split: option.splits)
qed
lemma compute_mult_scalar_poly_mapping [code]:
"Pm_fmap (fmap_of_list xs) ⊙ q = (case xs of ((t, c) # ys) ⇒
(monom_mult c t q + except (Pm_fmap (fmap_of_list ys)) {t} ⊙ q) | _ ⇒
Pm_fmap fmempty)"
proof (split list.splits, simp, intro conjI impI allI, goal_cases)
case (1 t c ys)
have "Pm_fmap (fmupd t c (fmap_of_list ys)) = sparse⇩0 [(t, c)] + except (sparse⇩0 ys) {t}"
by (auto simp: sparse⇩0_def fmlookup_default_def lookup_add lookup_except
split: option.splits intro!: poly_mapping_eqI)
also have "sparse⇩0 [(t, c)] = monomial c t"
by (auto simp: sparse⇩0_def lookup_single fmlookup_default_def intro!: poly_mapping_eqI)
finally show ?case
by (simp add: algebra_simps mult_scalar_monomial sparse⇩0_def)
qed
end
subsubsection ‹restore constructor view›
named_theorems mpoly_simps
definition "monomial1 pp = monomial 1 pp"
lemma monomial1_Nil[mpoly_simps]: "monomial1 0 = 1"
by (simp add: monomial1_def)
lemma monomial_mp: "monomial c (pp::'a⇒⇩0nat) = Const⇩0 c * monomial1 pp"
for c::"'b::comm_semiring_1"
by (auto intro!: poly_mapping_eqI simp: monomial1_def Const⇩0_def mult_single)
lemma monomial1_add: "(monomial1 (a + b)::('a::monoid_add⇒⇩0'b::comm_semiring_1)) = monomial1 a * monomial1 b"
by (auto simp: monomial1_def mult_single)
lemma monomial1_monomial: "monomial1 (monomial n v) = (Var⇩0 v::_⇒⇩0('b::comm_semiring_1))^n"
by (auto intro!: poly_mapping_eqI simp: monomial1_def Var⇩0_power lookup_single when_def)
lemma Ball_True: "(∀x∈X. True) ⟷ True" by auto
lemma Collect_False: "{x. False} = {}" by simp
lemma Pm_fmap_sum: "Pm_fmap f = (∑x ∈ fmdom' f. monomial (lookup0 f x) x)"
including fmap.lifting
by (auto intro!: poly_mapping_eqI sum.neutral
simp: fmlookup_default_def lookup_sum lookup_single when_def fmdom'I
split: option.splits)
lemma MPoly_numeral: "MPoly (numeral x) = numeral x"
by (metis monom.abs_eq monom_numeral single_numeral)
lemma MPoly_power: "MPoly (x ^ n) = MPoly x ^ n"
by (induction n) (auto simp: one_mpoly_def times_mpoly.abs_eq[symmetric])
lemmas [mpoly_simps] = Pm_fmap_sum
add.assoc[symmetric] mult.assoc[symmetric]
add_0 add_0_right mult_1 mult_1_right mult_zero_left mult_zero_right power_0 power_one_right
fmdom'_fmap_of_list
list.map fst_conv
sum.insert_remove finite_insert finite.emptyI
lookup0_fmap_of_list_simps
num.simps rel_simps
if_True if_False
insert_Diff_if insert_iff empty_Diff empty_iff
simp_thms
sum.empty
if_poly_mapping_eq_iff
keys_zero keys_one
keys_add_eq
keys_single
Un_insert_left Un_empty_left
Int_insert_left Int_empty_left
Collect_False
lookup_add lookup_single lookup_zero lookup_one
Set.ball_simps
when_simps
monomial_mp
monomial1_add
monomial1_monomial
Const⇩0_one Const⇩0_zero Const⇩0_numeral Const⇩0_minus
set_simps
text ‹A simproc for postprocessing with ‹mpoly_simps› and not polluting ‹[code_post]›:›
ML ‹val mpoly_simproc = Simplifier.make_simproc @{context} "multivariate polynomials"
{lhss = [@{term "Pm_fmap mpp::(_ ⇒⇩0 nat) ⇒⇩0 _"}],
proc = (K (fn ctxt => fn ct =>
SOME (Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps
(Named_Theorems.get ctxt (\<^named_theorems>‹mpoly_simps›))) ct)))}›
subsubsection ‹Ordered Power-Products›
lemma foldl_assoc:
assumes "⋀x y z. f (f x y) z = f x (f y z)"
shows "foldl f (f a b) xs = f a (foldl f b xs)"
proof (induct xs arbitrary: a b)
fix a b
show "foldl f (f a b) [] = f a (foldl f b [])" by simp
next
fix a b x xs
assume "⋀a b. foldl f (f a b) xs = f a (foldl f b xs)"
from assms[of a b x] this[of a "f b x"]
show "foldl f (f a b) (x # xs) = f a (foldl f b (x # xs))" unfolding foldl_Cons by simp
qed
context ordered_term
begin
definition list_max::"'t list ⇒ 't" where
"list_max xs ≡ foldl ord_term_lin.max min_term xs"
lemma list_max_Cons: "list_max (x # xs) = ord_term_lin.max x (list_max xs)"
unfolding list_max_def foldl_Cons
proof -
have "foldl ord_term_lin.max (ord_term_lin.max x min_term) xs =
ord_term_lin.max x (foldl ord_term_lin.max min_term xs)"
by (rule foldl_assoc, rule ord_term_lin.max.assoc)
from this ord_term_lin.max.commute[of min_term x]
show "foldl ord_term_lin.max (ord_term_lin.max min_term x) xs =
ord_term_lin.max x (foldl ord_term_lin.max min_term xs)" by simp
qed
lemma list_max_empty: "list_max [] = min_term"
unfolding list_max_def by simp
lemma list_max_in_list:
assumes "xs ≠ []"
shows "list_max xs ∈ set xs"
using assms
proof (induct xs, simp)
fix x xs
assume IH: "xs ≠ [] ⟹ list_max xs ∈ set xs"
show "list_max (x # xs) ∈ set (x # xs)"
proof (cases "xs = []")
case True
hence "list_max (x # xs) = ord_term_lin.max min_term x" unfolding list_max_def by simp
also have "… = x" unfolding ord_term_lin.max_def by (simp add: min_term_min)
finally show ?thesis by simp
next
assume "xs ≠ []"
show ?thesis
proof (cases "x ≼⇩t list_max xs")
case True
hence "list_max (x # xs) = list_max xs"
unfolding list_max_Cons ord_term_lin.max_def by simp
thus ?thesis using IH[OF ‹xs ≠ []›] by simp
next
case False
hence "list_max (x # xs) = x" unfolding list_max_Cons ord_term_lin.max_def by simp
thus ?thesis by simp
qed
qed
qed
lemma list_max_maximum:
assumes "a ∈ set xs"
shows "a ≼⇩t (list_max xs)"
using assms
proof (induct xs)
assume "a ∈ set []"
thus "a ≼⇩t list_max []" by simp
next
fix x xs
assume IH: "a ∈ set xs ⟹ a ≼⇩t list_max xs" and a_in: "a ∈ set (x # xs)"
from a_in have "a = x ∨ a ∈ set xs" by simp
thus "a ≼⇩t list_max (x # xs)" unfolding list_max_Cons
proof
assume "a = x"
thus "a ≼⇩t ord_term_lin.max x (list_max xs)" by simp
next
assume "a ∈ set xs"
from IH[OF this] show "a ≼⇩t ord_term_lin.max x (list_max xs)"
by (simp add: ord_term_lin.le_max_iff_disj)
qed
qed
lemma list_max_nonempty:
assumes "xs ≠ []"
shows "list_max xs = ord_term_lin.Max (set xs)"
proof -
have fin: "finite (set xs)" by simp
have "ord_term_lin.Max (set xs) = list_max xs"
proof (rule ord_term_lin.Max_eqI[OF fin, of "list_max xs"])
fix y
assume "y ∈ set xs"
from list_max_maximum[OF this] show "y ≼⇩t list_max xs" .
next
from list_max_in_list[OF assms] show "list_max xs ∈ set xs" .
qed
thus ?thesis by simp
qed
lemma in_set_clearjunk_iff_map_of_eq_Some:
"(a, b) ∈ set (AList.clearjunk xs) ⟷ map_of xs a = Some b"
by (metis Some_eq_map_of_iff distinct_clearjunk map_of_clearjunk)
lemma Pm_fmap_of_list_eq_zero_iff:
"Pm_fmap (fmap_of_list xs) = 0 ⟷ [(k, v)←AList.clearjunk xs . v ≠ 0] = []"
by (auto simp: poly_mapping_eq_iff fmlookup_default_def fun_eq_iff
in_set_clearjunk_iff_map_of_eq_Some filter_empty_conv fmlookup_of_list split: option.splits)
lemma fmdom'_clearjunk0: "fmdom' (clearjunk0 xs) = fmdom' xs - {x. fmlookup xs x = Some 0}"
by (metis (no_types, lifting) clearjunk0_def fmdom'_drop_set fmfilter_alt_defs(2) fmfilter_cong' mem_Collect_eq)
lemma compute_lt_poly_mapping[code]:
"lt (Pm_fmap (fmap_of_list xs)) = list_max (map fst [(k, v) ← AList.clearjunk xs. v ≠ 0])"
proof -
have "keys (Pm_fmap (fmap_of_list xs)) = fst ` {x ∈ set (AList.clearjunk xs). case x of (k, v) ⇒ v ≠ 0}"
by (auto simp: compute_keys_pp fmdom'_clearjunk0 fmap_of_list.rep_eq
in_set_clearjunk_iff_map_of_eq_Some fmdom'I image_iff fmlookup_dom'_iff)
then show ?thesis
unfolding lt_def
by (auto simp: Pm_fmap_of_list_eq_zero_iff list_max_empty list_max_nonempty)
qed
lemma compute_higher_poly_mapping [code]:
"higher (Pm_fmap xs) t = Pm_fmap (fmfilter (λk. t ≺⇩t k) xs)"
unfolding higher_def compute_except_poly_mapping
by (metis mem_Collect_eq ord_term_lin.leD ord_term_lin.leI)
lemma compute_lower_poly_mapping [code]:
"lower (Pm_fmap xs) t = Pm_fmap (fmfilter (λk. k ≺⇩t t) xs)"
unfolding lower_def compute_except_poly_mapping
by (metis mem_Collect_eq ord_term_lin.leD ord_term_lin.leI)
end
lifting_update poly_mapping.lifting
lifting_forget poly_mapping.lifting
subsection ‹Computations›
subsubsection ‹Scalar Polynomials›
type_synonym 'a mpoly_tc = "(nat ⇒⇩0 nat)⇒⇩0'a"
definition "shift_map_keys_punit = term_powerprod.shift_map_keys to_pair_unit fst"
lemma compute_shift_map_keys_punit [code]:
"shift_map_keys_punit t f (fmap_of_list xs) = fmap_of_list (map (λ(k, v). (t + k, f v)) xs)"
by (simp add: punit.compute_shift_map_keys shift_map_keys_punit_def)
global_interpretation punit: term_powerprod to_pair_unit fst
rewrites "punit.adds_term = (adds)"
and "punit.pp_of_term = (λx. x)"
and "punit.component_of_term = (λ_. ())"
defines monom_mult_punit = punit.monom_mult
and mult_scalar_punit = punit.mult_scalar
apply (fact MPoly_Type_Class.punit.term_powerprod_axioms)
apply (fact MPoly_Type_Class.punit_adds_term)
apply (fact MPoly_Type_Class.punit_pp_of_term)
apply (fact MPoly_Type_Class.punit_component_of_term)
done
lemma compute_monom_mult_punit [code]:
"monom_mult_punit c t (Pm_fmap xs) = Pm_fmap (if c = 0 then fmempty else shift_map_keys_punit t ((*) c) xs)"
by (simp add: monom_mult_punit_def punit.compute_monom_mult_poly_mapping shift_map_keys_punit_def)
lemma compute_mult_scalar_punit [code]:
"Pm_fmap (fmap_of_list xs) * q = (case xs of ((t, c) # ys) ⇒
(monom_mult_punit c t q + except (Pm_fmap (fmap_of_list ys)) {t} * q) | _ ⇒
Pm_fmap fmempty)"
by (simp only: punit_mult_scalar[symmetric] punit.compute_mult_scalar_poly_mapping monom_mult_punit_def)
locale trivariate⇩0_rat
begin
abbreviation X::"rat mpoly_tc" where "X ≡ Var⇩0 (0::nat)"
abbreviation Y::"rat mpoly_tc" where "Y ≡ Var⇩0 (1::nat)"
abbreviation Z::"rat mpoly_tc" where "Z ≡ Var⇩0 (2::nat)"
end
locale trivariate
begin
abbreviation "X ≡ Var 0"
abbreviation "Y ≡ Var 1"
abbreviation "Z ≡ Var 2"
end
experiment begin interpretation trivariate⇩0_rat .
lemma
"keys (X⇧2 * Z ^ 3 + 2 * Y ^ 3 * Z⇧2) =
{monomial 2 0 + monomial 3 2, monomial 3 1 + monomial 2 2}"
by eval
lemma
"keys (X⇧2 * Z ^ 3 + 2 * Y ^ 3 * Z⇧2) =
{monomial 2 0 + monomial 3 2, monomial 3 1 + monomial 2 2}"
by eval
lemma
"- 1 * X⇧2 * Z ^ 7 + - 2 * Y ^ 3 * Z⇧2 = - X⇧2 * Z ^ 7 + - 2 * Y ^ 3 * Z⇧2"
by eval
lemma
"X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2 + X⇧2 * Z ^ 4 + - 2 * Y ^ 3 * Z⇧2 = X⇧2 * Z ^ 7 + X⇧2 * Z ^ 4"
by eval
lemma
"X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2 - X⇧2 * Z ^ 4 + - 2 * Y ^ 3 * Z⇧2 =
X⇧2 * Z ^ 7 - X⇧2 * Z ^ 4"
by eval
lemma
"lookup (X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2 + 2) (sparse⇩0 [(0, 2), (2, 7)]) = 1"
by eval
lemma
"X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2 ≠
X⇧2 * Z ^ 4 + - 2 * Y ^ 3 * Z⇧2"
by eval
lemma
"0 * X^2 * Z^7 + 0 * Y^3*Z⇧2 = 0"
by eval
lemma
"monom_mult_punit 3 (sparse⇩0 [(1, 2::nat)]) (X⇧2 * Z + 2 * Y ^ 3 * Z⇧2) =
3 * Y⇧2 * Z * X⇧2 + 6 * Y ^ 5 * Z⇧2"
by eval
lemma
"monomial (-4) (sparse⇩0 [(0, 2::nat)]) = - 4 * X⇧2"
by eval
lemma "monomial (0::rat) (sparse⇩0 [(0::nat, 2::nat)]) = 0"
by eval
lemma
"(X⇧2 * Z + 2 * Y ^ 3 * Z⇧2) * (X⇧2 * Z ^ 3 + - 2 * Y ^ 3 * Z⇧2) =
X ^ 4 * Z ^ 4 + - 2 * X⇧2 * Z ^ 3 * Y ^ 3 +
- 4 * Y ^ 6 * Z ^ 4 + 2 * Y ^ 3 * Z ^ 5 * X⇧2"
by eval
end
subsubsection ‹Vector-Polynomials›
type_synonym 'a vmpoly_tc = "((nat ⇒⇩0 nat) × nat) ⇒⇩0 'a"
definition "shift_map_keys_pprod = pprod.shift_map_keys"
global_interpretation pprod: term_powerprod "λx. x" "λx. x"
rewrites "pprod.pp_of_term = fst"
and "pprod.component_of_term = snd"
defines splus_pprod = pprod.splus
and monom_mult_pprod = pprod.monom_mult
and mult_scalar_pprod = pprod.mult_scalar
and adds_term_pprod = pprod.adds_term
apply (fact MPoly_Type_Class.pprod.term_powerprod_axioms)
apply (fact MPoly_Type_Class.pprod_pp_of_term)
apply (fact MPoly_Type_Class.pprod_component_of_term)
done
lemma compute_adds_term_pprod [code_unfold]:
"adds_term_pprod u v = (snd u = snd v ∧ adds_pp_add_linorder (fst u) (fst v))"
by (simp add: adds_term_pprod_def pprod.adds_term_def adds_pp_add_linorder_def)
lemma compute_splus_pprod [code]: "splus_pprod t (s, i) = (t + s, i)"
by (simp add: splus_pprod_def pprod.splus_def)
lemma compute_shift_map_keys_pprod [code]:
"shift_map_keys_pprod t f (fmap_of_list xs) = fmap_of_list (map (λ(k, v). (splus_pprod t k, f v)) xs)"
by (simp add: pprod.compute_shift_map_keys shift_map_keys_pprod_def splus_pprod_def)
lemma compute_monom_mult_pprod [code]:
"monom_mult_pprod c t (Pm_fmap xs) = Pm_fmap (if c = 0 then fmempty else shift_map_keys_pprod t ((*) c) xs)"
by (simp add: monom_mult_pprod_def pprod.compute_monom_mult_poly_mapping shift_map_keys_pprod_def)
lemma compute_mult_scalar_pprod [code]:
"mult_scalar_pprod (Pm_fmap (fmap_of_list xs)) q = (case xs of ((t, c) # ys) ⇒
(monom_mult_pprod c t q + mult_scalar_pprod (except (Pm_fmap (fmap_of_list ys)) {t}) q) | _ ⇒
Pm_fmap fmempty)"
by (simp only: mult_scalar_pprod_def pprod.compute_mult_scalar_poly_mapping monom_mult_pprod_def)
definition Vec⇩0 :: "nat ⇒ (('a ⇒⇩0 nat) ⇒⇩0 'b) ⇒ (('a ⇒⇩0 nat) × nat) ⇒⇩0 'b::semiring_1" where
"Vec⇩0 i p = mult_scalar_pprod p (Poly_Mapping.single (0, i) 1)"
experiment begin interpretation trivariate⇩0_rat .
lemma
"keys (Vec⇩0 0 (X⇧2 * Z ^ 3) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2)) =
{(sparse⇩0 [(0, 2), (2, 3)], 0), (sparse⇩0 [(1, 3), (2, 2)], 1)}"
by eval
lemma
"keys (Vec⇩0 0 (X⇧2 * Z ^ 3) + Vec⇩0 2 (2 * Y ^ 3 * Z⇧2)) =
{(sparse⇩0 [(0, 2), (2, 3)], 0), (sparse⇩0 [(1, 3), (2, 2)], 2)}"
by eval
lemma
"Vec⇩0 1 (X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2) + Vec⇩0 3 (X⇧2 * Z ^ 4) + Vec⇩0 1 (- 2 * Y ^ 3 * Z⇧2) =
Vec⇩0 1 (X⇧2 * Z ^ 7) + Vec⇩0 3 (X⇧2 * Z ^ 4)"
by eval
lemma
"lookup (Vec⇩0 0 (X⇧2 * Z ^ 7) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2 + 2)) (sparse⇩0 [(0, 2), (2, 7)], 0) = 1"
by eval
lemma
"lookup (Vec⇩0 0 (X⇧2 * Z ^ 7) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2 + 2)) (sparse⇩0 [(0, 2), (2, 7)], 1) = 0"
by eval
lemma
"Vec⇩0 0 (0 * X^2 * Z^7) + Vec⇩0 1 (0 * Y^3*Z⇧2) = 0"
by eval
lemma
"monom_mult_pprod 3 (sparse⇩0 [(1, 2::nat)]) (Vec⇩0 0 (X⇧2 * Z) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2)) =
Vec⇩0 0 (3 * Y⇧2 * Z * X⇧2) + Vec⇩0 1 (6 * Y ^ 5 * Z⇧2)"
by eval
end
subsection ‹Code setup for type MPoly›
text ‹postprocessing from ‹Var⇩0, Const⇩0› to ‹Var, Const›.›
lemmas [code_post] =
plus_mpoly.abs_eq[symmetric]
times_mpoly.abs_eq[symmetric]
MPoly_numeral
MPoly_power
one_mpoly_def[symmetric]
Var.abs_eq[symmetric]
Const.abs_eq[symmetric]
instantiation mpoly::("{equal, zero}")equal begin
lift_definition equal_mpoly:: "'a mpoly ⇒ 'a mpoly ⇒ bool" is HOL.equal .
instance proof standard qed (transfer, rule equal_eq)
end
experiment begin interpretation trivariate .
lemmas [mpoly_simps] = plus_mpoly.abs_eq
lemma "content_primitive (4 * X * Y^2 * Z^3 + 6 * X⇧2 * Y^4 + 8 * X⇧2 * Y^5) =
(2::int, 2 * X * Y⇧2 * Z ^ 3 + 3 * X⇧2 * Y ^ 4 + 4 * X⇧2 * Y ^ 5)"
by eval
end
end
Theory PP_Type
theory PP_Type
imports Power_Products
begin
text ‹For code generation, we must introduce a copy of type @{typ "'a ⇒⇩0 'b"} for power-products.›
typedef (overloaded) ('a, 'b) pp = "UNIV::('a ⇒⇩0 'b) set"
morphisms mapping_of PP ..
setup_lifting type_definition_pp
lift_definition pp_of_fun :: "('a ⇒ 'b) ⇒ ('a, 'b::zero) pp"
is Abs_poly_mapping .
subsection ‹‹lookup_pp›, ‹keys_pp› and ‹single_pp››
lift_definition lookup_pp :: "('a, 'b::zero) pp ⇒ 'a ⇒ 'b" is lookup .
lift_definition keys_pp :: "('a, 'b::zero) pp ⇒ 'a set" is keys .
lift_definition single_pp :: "'a ⇒ 'b ⇒ ('a, 'b::zero) pp" is Poly_Mapping.single .
lemma lookup_pp_of_fun: "finite {x. f x ≠ 0} ⟹ lookup_pp (pp_of_fun f) = f"
by (transfer, rule Abs_poly_mapping_inverse, simp)
lemma pp_of_lookup: "pp_of_fun (lookup_pp t) = t"
by (transfer, fact lookup_inverse)
lemma pp_eqI: "(⋀u. lookup_pp s u = lookup_pp t u) ⟹ s = t"
by (transfer, rule poly_mapping_eqI)
lemma pp_eq_iff: "(s = t) ⟷ (lookup_pp s = lookup_pp t)"
by (auto intro: pp_eqI)
lemma keys_pp_iff: "x ∈ keys_pp t ⟷ (lookup_pp t x ≠ 0)"
by (simp add: in_keys_iff keys_pp.rep_eq lookup_pp.rep_eq)
lemma pp_eqI':
assumes "⋀u. u ∈ keys_pp s ∪ keys_pp t ⟹ lookup_pp s u = lookup_pp t u"
shows "s = t"
proof (rule pp_eqI)
fix u
show "lookup_pp s u = lookup_pp t u"
proof (cases "u ∈ keys_pp s ∪ keys_pp t")
case True
thus ?thesis by (rule assms)
next
case False
thus ?thesis by (simp add: keys_pp_iff)
qed
qed
lemma lookup_single_pp: "lookup_pp (single_pp x e) y = (e when x = y)"
by (transfer, simp only: lookup_single)
subsection ‹Additive Structure›
instantiation pp :: (type, zero) zero
begin
lift_definition zero_pp :: "('a, 'b) pp" is "0::'a ⇒⇩0 'b" .
lemma lookup_zero_pp [simp]: "lookup_pp 0 = 0"
by (transfer, simp add: lookup_zero_fun)
instance ..
end
lemma single_pp_zero [simp]: "single_pp x 0 = 0"
by (rule pp_eqI, simp add: lookup_single_pp)
instantiation pp :: (type, monoid_add) monoid_add
begin
lift_definition plus_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ ('a, 'b) pp" is "(+)::('a ⇒⇩0 'b) ⇒ _" .
lemma lookup_plus_pp: "lookup_pp (s + t) = lookup_pp s + lookup_pp t"
by (transfer, simp add: lookup_plus_fun)
instance by intro_classes (transfer, simp add: fun_eq_iff add.assoc)+
end
lemma single_pp_plus: "single_pp x a + single_pp x b = single_pp x (a + b)"
by (rule pp_eqI, simp add: lookup_single_pp lookup_plus_pp when_def)
instance pp :: (type, comm_monoid_add) comm_monoid_add
by intro_classes (transfer, simp add: fun_eq_iff ac_simps)+
instantiation pp :: (type, cancel_comm_monoid_add) cancel_comm_monoid_add
begin
lift_definition minus_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ ('a, 'b) pp" is "(-)::('a ⇒⇩0 'b) ⇒ _" .
lemma lookup_minus_pp: "lookup_pp (s - t) = lookup_pp s - lookup_pp t"
by (transfer, simp only: lookup_minus_fun)
instance by intro_classes (transfer, simp add: fun_eq_iff diff_diff_add)+
end
subsection ‹@{typ "('a, 'b) poly_mapping"} belongs to class @{class comm_powerprod}›
instance poly_mapping :: (type, cancel_comm_monoid_add) comm_powerprod
by standard
subsection ‹@{typ "('a, 'b) poly_mapping"} belongs to class @{class ninv_comm_monoid_add}›
instance poly_mapping :: (type, ninv_comm_monoid_add) ninv_comm_monoid_add
proof (standard, transfer)
fix s t::"'a ⇒ 'b"
assume "(λk. s k + t k) = (λ_. 0)"
hence "s + t = 0" by (simp only: plus_fun_def zero_fun_def)
hence "s = 0" by (rule plus_eq_zero)
thus "s = (λ_. 0)" by (simp only: zero_fun_def)
qed
subsection ‹@{typ "('a, 'b) pp"} belongs to class @{class lcs_powerprod}›
lemma adds_pp_iff: "(s adds t) ⟷ (mapping_of s adds mapping_of t)"
unfolding adds_def by (transfer, fact refl)
instantiation pp :: (type, add_linorder) lcs_powerprod
begin
lift_definition lcs_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ ('a, 'b) pp" is "lcs_powerprod_class.lcs" .
lemma lookup_lcs_pp: "lookup_pp (lcs s t) x = max (lookup_pp s x) (lookup_pp t x)"
by (transfer, simp add: lookup_lcs_fun lcs_fun_def)
instance
apply (intro_classes, simp_all only: adds_pp_iff)
subgoal by (transfer, rule adds_lcs)
subgoal by (transfer, elim lcs_adds)
subgoal by (transfer, rule lcs_comm)
done
end
subsection ‹@{typ "('a, 'b) pp"} belongs to class @{class ulcs_powerprod}›
instance pp :: (type, add_linorder_min) ulcs_powerprod by intro_classes (transfer, elim plus_eq_zero)
subsection ‹Dickson's lemma for power-products in finitely many indeterminates›
lemma almost_full_on_pp_iff:
"almost_full_on (adds) A ⟷ almost_full_on (adds) (mapping_of ` A)" (is "?l ⟷ ?r")
proof
assume ?l
with _ show ?r
proof (rule almost_full_on_hom)
fix x y :: "('a, 'b) pp"
assume "x adds y"
thus "mapping_of x adds mapping_of y" by (simp only: adds_pp_iff)
qed
next
assume ?r
hence "almost_full_on (λx y. mapping_of x adds mapping_of y) A"
using subset_refl by (rule almost_full_on_map)
thus ?l by (simp only: adds_pp_iff[symmetric])
qed
lift_definition varnum_pp :: "('a::countable, 'b::zero) pp ⇒ nat" is "varnum {}" .
lemma dickson_grading_varnum_pp:
"dickson_grading (varnum_pp::('a::countable, 'b::add_wellorder) pp ⇒ nat)"
proof (rule dickson_gradingI)
fix s t :: "('a, 'b) pp"
show "varnum_pp (s + t) = max (varnum_pp s) (varnum_pp t)" by (transfer, rule varnum_plus)
next
fix m::nat
show "almost_full_on (adds) {x::('a, 'b) pp. varnum_pp x ≤ m}" unfolding almost_full_on_pp_iff
proof (transfer, simp)
fix m::nat
from dickson_grading_varnum_empty show "almost_full_on (adds) {x::'a ⇒⇩0 'b. varnum {} x ≤ m}"
by (rule dickson_gradingD2)
qed
qed
instance pp :: (countable, add_wellorder) graded_dickson_powerprod
by (standard, rule, fact dickson_grading_varnum_pp)
instance pp :: (finite, add_wellorder) dickson_powerprod
proof
have eq: "range mapping_of = UNIV" by (rule surjI, rule PP_inverse, rule UNIV_I)
show "almost_full_on (adds) (UNIV::('a, 'b) pp set)" by (simp add: almost_full_on_pp_iff eq dickson)
qed
subsection ‹Lexicographic Term Order›
lift_definition lex_pp :: "('a, 'b) pp ⇒ ('a::linorder, 'b::{zero,linorder}) pp ⇒ bool" is lex_pm .
lift_definition lex_pp_strict :: "('a, 'b) pp ⇒ ('a::linorder, 'b::{zero,linorder}) pp ⇒ bool" is lex_pm_strict .
lemma lex_pp_alt: "lex_pp s t = (s = t ∨ (∃x. lookup_pp s x < lookup_pp t x ∧ (∀y<x. lookup_pp s y = lookup_pp t y)))"
by (transfer, fact lex_pm_alt)
lemma lex_pp_refl: "lex_pp s s"
by (transfer, fact lex_pm_refl)
lemma lex_pp_antisym: "lex_pp s t ⟹ lex_pp t s ⟹ s = t"
by (transfer, intro lex_pm_antisym)
lemma lex_pp_trans: "lex_pp s t ⟹ lex_pp t u ⟹ lex_pp s u"
by (transfer, rule lex_pm_trans)
lemma lex_pp_lin: "lex_pp s t ∨ lex_pp t s"
by (transfer, fact lex_pm_lin)
lemma lex_pp_lin': "¬ lex_pp t s ⟹ lex_pp s t"
using lex_pp_lin by blast
corollary lex_pp_strict_alt [code]:
"lex_pp_strict s t = (¬ lex_pp t s)" for s t::"(_, _::ordered_comm_monoid_add) pp"
by (transfer, fact lex_pm_strict_alt)
lemma lex_pp_zero_min: "lex_pp 0 s" for s::"(_, _::add_linorder_min) pp"
by (transfer, fact lex_pm_zero_min)
lemma lex_pp_plus_monotone: "lex_pp s t ⟹ lex_pp (s + u) (t + u)"
for s t::"(_, _::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) pp"
by (transfer, intro lex_pm_plus_monotone)
lemma lex_pp_plus_monotone': "lex_pp s t ⟹ lex_pp (u + s) (u + t)"
for s t::"(_, _::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) pp"
unfolding add.commute[of u] by (rule lex_pp_plus_monotone)
instantiation pp :: (linorder, "{ordered_comm_monoid_add, linorder}") linorder
begin
definition less_eq_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ bool"
where "less_eq_pp = lex_pp"
definition less_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ bool"
where "less_pp = lex_pp_strict"
instance by intro_classes (auto simp: less_eq_pp_def less_pp_def lex_pp_refl lex_pp_strict_alt intro: lex_pp_antisym lex_pp_lin' elim: lex_pp_trans)
end
subsection ‹Degree›
lift_definition deg_pp :: "('a, 'b::comm_monoid_add) pp ⇒ 'b" is deg_pm .
lemma deg_pp_alt: "deg_pp s = sum (lookup_pp s) (keys_pp s)"
by (transfer, transfer, simp add: deg_fun_def supp_fun_def)
lemma deg_pp_zero [simp]: "deg_pp 0 = 0"
by (transfer, fact deg_pm_zero)
lemma deg_pp_eq_0_iff [simp]: "deg_pp s = 0 ⟷ s = 0" for s::"('a, 'b::add_linorder_min) pp"
by (transfer, fact deg_pm_eq_0_iff)
lemma deg_pp_plus: "deg_pp (s + t) = deg_pp s + deg_pp (t::('a, 'b::comm_monoid_add) pp)"
by (transfer, fact deg_pm_plus)
lemma deg_pp_single: "deg_pp (single_pp x k) = k"
by (transfer, fact deg_pm_single)
subsection ‹Degree-Lexicographic Term Order›
lift_definition dlex_pp :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp ⇒ ('a, 'b) pp ⇒ bool"
is dlex_pm .
lift_definition dlex_pp_strict :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp ⇒ ('a, 'b) pp ⇒ bool"
is dlex_pm_strict .
lemma dlex_pp_alt: "dlex_pp s t ⟷ (deg_pp s < deg_pp t ∨ (deg_pp s = deg_pp t ∧ lex_pp s t))"
by transfer (simp only: dlex_pm_def dord_pm_alt)
lemma dlex_pp_refl: "dlex_pp s s"
by (transfer) (fact dlex_pm_refl)
lemma dlex_pp_antisym: "dlex_pp s t ⟹ dlex_pp t s ⟹ s = t"
by (transfer, elim dlex_pm_antisym)
lemma dlex_pp_trans: "dlex_pp s t ⟹ dlex_pp t u ⟹ dlex_pp s u"
by (transfer, rule dlex_pm_trans)
lemma dlex_pp_lin: "dlex_pp s t ∨ dlex_pp t s"
by (transfer, fact dlex_pm_lin)
corollary dlex_pp_strict_alt [code]: "dlex_pp_strict s t = (¬ dlex_pp t s)"
by (transfer, fact dlex_pm_strict_alt)
lemma dlex_pp_zero_min: "dlex_pp 0 s"
for s t::"(_, _::add_linorder_min) pp"
by (transfer, fact dlex_pm_zero_min)
lemma dlex_pp_plus_monotone: "dlex_pp s t ⟹ dlex_pp (s + u) (t + u)"
for s t::"(_, _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}) pp"
by (transfer, rule dlex_pm_plus_monotone)
subsection ‹Degree-Reverse-Lexicographic Term Order›
lift_definition drlex_pp :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp ⇒ ('a, 'b) pp ⇒ bool"
is drlex_pm .
lift_definition drlex_pp_strict :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp ⇒ ('a, 'b) pp ⇒ bool"
is drlex_pm_strict .
lemma drlex_pp_alt: "drlex_pp s t ⟷ (deg_pp s < deg_pp t ∨ (deg_pp s = deg_pp t ∧ lex_pp t s))"
by transfer (simp only: drlex_pm_def dord_pm_alt)
lemma drlex_pp_refl: "drlex_pp s s"
by (transfer, fact drlex_pm_refl)
lemma drlex_pp_antisym: "drlex_pp s t ⟹ drlex_pp t s ⟹ s = t"
by (transfer, rule drlex_pm_antisym)
lemma drlex_pp_trans: "drlex_pp s t ⟹ drlex_pp t u ⟹ drlex_pp s u"
by (transfer, rule drlex_pm_trans)
lemma drlex_pp_lin: "drlex_pp s t ∨ drlex_pp t s"
by (transfer, fact drlex_pm_lin)
corollary drlex_pp_strict_alt [code]: "drlex_pp_strict s t = (¬ drlex_pp t s)"
by (transfer, fact drlex_pm_strict_alt)
lemma drlex_pp_zero_min: "drlex_pp 0 s"
for s t::"(_, _::add_linorder_min) pp"
by (transfer, fact drlex_pm_zero_min)
lemma drlex_pp_plus_monotone: "drlex_pp s t ⟹ drlex_pp (s + u) (t + u)"
for s t::"(_, _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}) pp"
by (transfer, rule drlex_pm_plus_monotone)
end
Theory OAlist
section ‹Associative Lists with Sorted Keys›
theory OAlist
imports Deriving.Comparator
begin
text ‹We define the type of @{emph ‹ordered associative lists›} (oalist). An oalist is an associative
list (i.\,e. a list of pairs) such that the keys are distinct and sorted wrt. some linear
order relation, and no key is mapped to @{term 0}. The latter invariant allows to implement various
functions operating on oalists more efficiently.
The ordering of the keys in an oalist ‹xs› is encoded as an additional parameter of ‹xs›.
This means that oalists may be ordered wrt. different orderings, even if they are of the same type.
Operations operating on more than one oalists, like ‹map2_val›, typically ensure that the orderings
of their arguments are identical by re-ordering one argument wrt. the order relation of the other.
This, however, implies that equality of order relations must be effectively decidable if executable
code is to be generated.›
subsection ‹Preliminaries›
fun min_list_param :: "('a ⇒ 'a ⇒ bool) ⇒ 'a list ⇒ 'a" where
"min_list_param rel (x # xs) = (case xs of [] ⇒ x | _ ⇒ (let m = min_list_param rel xs in if rel x m then x else m))"
lemma min_list_param_in:
assumes "xs ≠ []"
shows "min_list_param rel xs ∈ set xs"
using assms
proof (induct xs)
case Nil
thus ?case by simp
next
case (Cons x xs)
show ?case
proof (simp add: min_list_param.simps[of rel x xs] Let_def del: min_list_param.simps set_simps(2) split: list.split,
intro conjI impI allI, simp, simp)
fix y ys
assume xs: "xs = y # ys"
have "min_list_param rel (y # ys) = min_list_param rel xs" by (simp only: xs)
also have "... ∈ set xs" by (rule Cons(1), simp add: xs)
also have "... ⊆ set (x # y # ys)" by (auto simp: xs)
finally show "min_list_param rel (y # ys) ∈ set (x # y # ys)" .
qed
qed
lemma min_list_param_minimal:
assumes "transp rel" and "⋀x y. x ∈ set xs ⟹ y ∈ set xs ⟹ rel x y ∨ rel y x"
and "z ∈ set xs"
shows "rel (min_list_param rel xs) z"
using assms(2, 3)
proof (induct xs)
case Nil
from Nil(2) show ?case by simp
next
case (Cons x xs)
from Cons(3) have disj1: "z = x ∨ z ∈ set xs" by simp
have "x ∈ set (x # xs)" by simp
hence disj2: "rel x z ∨ rel z x" using Cons(3) by (rule Cons(2))
have *: "rel (min_list_param rel xs) z" if "z ∈ set xs" using _ that
proof (rule Cons(1))
fix a b
assume "a ∈ set xs" and "b ∈ set xs"
hence "a ∈ set (x # xs)" and "b ∈ set (x # xs)" by simp_all
thus "rel a b ∨ rel b a" by (rule Cons(2))
qed
show ?case
proof (simp add: min_list_param.simps[of rel x xs] Let_def del: min_list_param.simps set_simps(2) split: list.split,
intro conjI impI allI)
assume "xs = []"
with disj1 disj2 show "rel x z" by simp
next
fix y ys
assume "xs = y # ys" and "rel x (min_list_param rel (y # ys))"
hence "rel x (min_list_param rel xs)" by simp
from disj1 show "rel x z"
proof
assume "z = x"
thus ?thesis using disj2 by simp
next
assume "z ∈ set xs"
hence "rel (min_list_param rel xs) z" by (rule *)
with assms(1) ‹rel x (min_list_param rel xs)› show ?thesis by (rule transpD)
qed
next
fix y ys
assume xs: "xs = y # ys" and "¬ rel x (min_list_param rel (y # ys))"
from disj1 show "rel (min_list_param rel (y # ys)) z"
proof
assume "z = x"
have "min_list_param rel (y # ys) ∈ set (y # ys)" by (rule min_list_param_in, simp)
hence "min_list_param rel (y # ys) ∈ set (x # xs)" by (simp add: xs)
with ‹x ∈ set (x # xs)› have "rel x (min_list_param rel (y # ys)) ∨ rel (min_list_param rel (y # ys)) x"
by (rule Cons(2))
with ‹¬ rel x (min_list_param rel (y # ys))› have "rel (min_list_param rel (y # ys)) x" by simp
thus ?thesis by (simp only: ‹z = x›)
next
assume "z ∈ set xs"
hence "rel (min_list_param rel xs) z" by (rule *)
thus ?thesis by (simp only: xs)
qed
qed
qed
definition comp_of_ord :: "('a ⇒ 'a ⇒ bool) ⇒ 'a comparator" where
"comp_of_ord le x y = (if le x y then if x = y then Eq else Lt else Gt)"
lemma comp_of_ord_eq_comp_of_ords:
assumes "antisymp le"
shows "comp_of_ord le = comp_of_ords le (λx y. le x y ∧ ¬ le y x)"
by (intro ext, auto simp: comp_of_ord_def comp_of_ords_def intro: assms antisympD)
lemma comparator_converse:
assumes "comparator cmp"
shows "comparator (λx y. cmp y x)"
proof -
from assms interpret comp: comparator cmp .
show ?thesis by (unfold_locales, auto simp: comp.eq comp.sym intro: comp.trans)
qed
lemma comparator_composition:
assumes "comparator cmp" and "inj f"
shows "comparator (λx y. cmp (f x) (f y))"
proof -
from assms(1) interpret comp: comparator cmp .
from assms(2) have *: "x = y" if "f x = f y" for x y using that by (rule injD)
show ?thesis by (unfold_locales, auto simp: comp.sym comp.eq * intro: comp.trans)
qed
subsection ‹Type ‹key_order››
typedef 'a key_order = "{compare :: 'a comparator. comparator compare}"
morphisms key_compare Abs_key_order
proof -
from well_order_on obtain r where "well_order_on (UNIV::'a set) r" ..
hence "linear_order r" by (simp only: well_order_on_def)
hence lin: "(x, y) ∈ r ∨ (y, x) ∈ r" for x y
by (metis Diff_iff Linear_order_in_diff_Id UNIV_I ‹well_order r› well_order_on_Field)
have antisym: "(x, y) ∈ r ⟹ (y, x) ∈ r ⟹ x = y" for x y
by (meson ‹linear_order r› antisymD linear_order_on_def partial_order_on_def)
have trans: "(x, y) ∈ r ⟹ (y, z) ∈ r ⟹ (x, z) ∈ r" for x y z
by (meson ‹linear_order r› linear_order_on_def order_on_defs(1) partial_order_on_def trans_def)
define comp where "comp = (λx y. if (x, y) ∈ r then if (y, x) ∈ r then Eq else Lt else Gt)"
show ?thesis
proof (rule, simp)
show "comparator comp"
proof (standard, simp_all add: comp_def split: if_splits, intro impI)
fix x y
assume "(x, y) ∈ r" and "(y, x) ∈ r"
thus "x = y" by (rule antisym)
next
fix x y
assume "(x, y) ∉ r"
with lin show "(y, x) ∈ r" by blast
next
fix x y z
assume "(y, x) ∉ r" and "(z, y) ∉ r"
assume "(x, y) ∈ r" and "(y, z) ∈ r"
hence "(x, z) ∈ r" by (rule trans)
moreover have "(z, x) ∉ r"
proof
assume "(z, x) ∈ r"
with ‹(x, z) ∈ r› have "x = z" by (rule antisym)
from ‹(z, y) ∉ r› ‹(x, y) ∈ r› show False unfolding ‹x = z› ..
qed
ultimately show "(z, x) ∉ r ∧ ((z, x) ∉ r ⟶ (x, z) ∈ r)" by simp
qed
qed
qed
lemma comparator_key_compare [simp, intro!]: "comparator (key_compare ko)"
using key_compare[of ko] by simp
instantiation key_order :: (type) equal
begin
definition equal_key_order :: "'a key_order ⇒ 'a key_order ⇒ bool" where "equal_key_order = (=)"
instance by (standard, simp add: equal_key_order_def)
end
setup_lifting type_definition_key_order
instantiation key_order :: (type) uminus
begin
lift_definition uminus_key_order :: "'a key_order ⇒ 'a key_order" is "λc x y. c y x"
by (fact comparator_converse)
instance ..
end
lift_definition le_of_key_order :: "'a key_order ⇒ 'a ⇒ 'a ⇒ bool" is "λcmp. le_of_comp cmp" .
lift_definition lt_of_key_order :: "'a key_order ⇒ 'a ⇒ 'a ⇒ bool" is "λcmp. lt_of_comp cmp" .
definition key_order_of_ord :: "('a ⇒ 'a ⇒ bool) ⇒ 'a key_order"
where "key_order_of_ord ord = Abs_key_order (comp_of_ord ord)"
lift_definition key_order_of_le :: "'a::linorder key_order" is comparator_of
by (fact comparator_of)
interpretation key_order_lin: linorder "le_of_key_order ko" "lt_of_key_order ko"
proof transfer
fix comp::"'a comparator"
assume "comparator comp"
then interpret comp: comparator comp .
show "class.linorder comp.le comp.lt" by (fact comp.linorder)
qed
lemma le_of_key_order_alt: "le_of_key_order ko x y = (key_compare ko x y ≠ Gt)"
by (transfer, simp add: comparator.nGt_le_conv)
lemma lt_of_key_order_alt: "lt_of_key_order ko x y = (key_compare ko x y = Lt)"
by (transfer, meson comparator.Lt_lt_conv)
lemma key_compare_Gt: "key_compare ko x y = Gt ⟷ key_compare ko y x = Lt"
by (transfer, meson comparator.nGt_le_conv comparator.nLt_le_conv)
lemma key_compare_Eq: "key_compare ko x y = Eq ⟷ x = y"
by (transfer, simp add: comparator.eq)
lemma key_compare_same [simp]: "key_compare ko x x = Eq"
by (simp add: key_compare_Eq)
lemma uminus_key_compare [simp]: "invert_order (key_compare ko x y) = key_compare ko y x"
by (transfer, simp add: comparator.sym)
lemma key_compare_uminus [simp]: "key_compare (- ko) x y = key_compare ko y x"
by (transfer, rule refl)
lemma uminus_key_order_sameD:
assumes "- ko = (ko::'a key_order)"
shows "x = (y::'a)"
proof (rule ccontr)
assume "x ≠ y"
hence "key_compare ko x y ≠ Eq" by (simp add: key_compare_Eq)
hence "key_compare ko x y ≠ invert_order (key_compare ko x y)"
by (metis invert_order.elims order.distinct(5))
also have "invert_order (key_compare ko x y) = key_compare (- ko) x y" by simp
finally have "- ko ≠ ko" by (auto simp del: key_compare_uminus)
thus False using assms ..
qed
lemma key_compare_key_order_of_ord:
assumes "antisymp ord" and "transp ord" and "⋀x y. ord x y ∨ ord y x"
shows "key_compare (key_order_of_ord ord) = (λx y. if ord x y then if x = y then Eq else Lt else Gt)"
proof -
have eq: "key_compare (key_order_of_ord ord) = comp_of_ord ord"
unfolding key_order_of_ord_def comp_of_ord_eq_comp_of_ords[OF assms(1)]
proof (rule Abs_key_order_inverse, simp, rule comp_of_ords, unfold_locales)
fix x
from assms(3) show "ord x x" by blast
next
fix x y z
assume "ord x y" and "ord y z"
with assms(2) show "ord x z" by (rule transpD)
next
fix x y
assume "ord x y" and "ord y x"
with assms(1) show "x = y" by (rule antisympD)
qed (rule refl, rule assms(3))
have *: "x = y" if "ord x y" and "ord y x" for x y using assms(1) that by (rule antisympD)
show ?thesis by (rule, rule, auto simp: eq comp_of_ord_def intro: *)
qed
lemma key_compare_key_order_of_le:
"key_compare key_order_of_le = (λx y. if x < y then Lt else if x = y then Eq else Gt)"
by (transfer, intro ext, fact comparator_of_def)
subsection ‹Invariant in Context @{locale comparator}›
context comparator
begin
definition oalist_inv_raw :: "('a × 'b::zero) list ⇒ bool"
where "oalist_inv_raw xs ⟷ (0 ∉ snd ` set xs ∧ sorted_wrt lt (map fst xs))"
lemma oalist_inv_rawI:
assumes "0 ∉ snd ` set xs" and "sorted_wrt lt (map fst xs)"
shows "oalist_inv_raw xs"
unfolding oalist_inv_raw_def using assms unfolding fst_conv snd_conv by blast
lemma oalist_inv_rawD1:
assumes "oalist_inv_raw xs"
shows "0 ∉ snd ` set xs"
using assms unfolding oalist_inv_raw_def fst_conv by blast
lemma oalist_inv_rawD2:
assumes "oalist_inv_raw xs"
shows "sorted_wrt lt (map fst xs)"
using assms unfolding oalist_inv_raw_def fst_conv snd_conv by blast
lemma oalist_inv_raw_Nil: "oalist_inv_raw []"
by (simp add: oalist_inv_raw_def)
lemma oalist_inv_raw_singleton: "oalist_inv_raw [(k, v)] ⟷ (v ≠ 0)"
by (auto simp: oalist_inv_raw_def)
lemma oalist_inv_raw_ConsI:
assumes "oalist_inv_raw xs" and "v ≠ 0" and "xs ≠ [] ⟹ lt k (fst (hd xs))"
shows "oalist_inv_raw ((k, v) # xs)"
proof (rule oalist_inv_rawI)
from assms(1) have "0 ∉ snd ` set xs" by (rule oalist_inv_rawD1)
with assms(2) show "0 ∉ snd ` set ((k, v) # xs)" by simp
next
show "sorted_wrt lt (map fst ((k, v) # xs))"
proof (cases "xs = []")
case True
thus ?thesis by simp
next
case False
then obtain k' v' xs' where xs: "xs = (k', v') # xs'" by (metis list.exhaust prod.exhaust)
from assms(3)[OF False] have "lt k k'" by (simp add: xs)
moreover from assms(1) have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
ultimately show "sorted_wrt lt (map fst ((k, v) # xs))"
by (simp add: xs sorted_wrt2[OF transp_less] del: sorted_wrt.simps)
qed
qed
lemma oalist_inv_raw_ConsD1:
assumes "oalist_inv_raw (x # xs)"
shows "oalist_inv_raw xs"
proof (rule oalist_inv_rawI)
from assms have "0 ∉ snd ` set (x # xs)" by (rule oalist_inv_rawD1)
thus "0 ∉ snd ` set xs" by simp
next
from assms have "sorted_wrt lt (map fst (x # xs))" by (rule oalist_inv_rawD2)
thus "sorted_wrt lt (map fst xs)" by simp
qed
lemma oalist_inv_raw_ConsD2:
assumes "oalist_inv_raw ((k, v) # xs)"
shows "v ≠ 0"
proof -
from assms have "0 ∉ snd ` set ((k, v) # xs)" by (rule oalist_inv_rawD1)
thus ?thesis by auto
qed
lemma oalist_inv_raw_ConsD3:
assumes "oalist_inv_raw ((k, v) # xs)" and "k' ∈ fst ` set xs"
shows "lt k k'"
proof -
from assms(2) obtain x where "x ∈ set xs" and "k' = fst x" by fastforce
from assms(1) have "sorted_wrt lt (map fst ((k, v) # xs))" by (rule oalist_inv_rawD2)
hence "∀x∈set xs. lt k (fst x)" by simp
hence "lt k (fst x)" using ‹x ∈ set xs› ..
thus ?thesis by (simp only: ‹k' = fst x›)
qed
lemma oalist_inv_raw_tl:
assumes "oalist_inv_raw xs"
shows "oalist_inv_raw (tl xs)"
proof (rule oalist_inv_rawI)
from assms have "0 ∉ snd ` set xs" by (rule oalist_inv_rawD1)
thus "0 ∉ snd ` set (tl xs)" by (metis (no_types, lifting) image_iff list.set_sel(2) tl_Nil)
next
show "sorted_wrt lt (map fst (tl xs))"
by (metis hd_Cons_tl oalist_inv_rawD2 oalist_inv_raw_ConsD1 assms tl_Nil)
qed
lemma oalist_inv_raw_filter:
assumes "oalist_inv_raw xs"
shows "oalist_inv_raw (filter P xs)"
proof (rule oalist_inv_rawI)
from assms have "0 ∉ snd ` set xs" by (rule oalist_inv_rawD1)
thus "0 ∉ snd ` set (filter P xs)" by auto
next
from assms have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
thus "sorted_wrt lt (map fst (filter P xs))" by (induct xs, simp, simp)
qed
lemma oalist_inv_raw_map:
assumes "oalist_inv_raw xs"
and "⋀a. snd (f a) = 0 ⟹ snd a = 0"
and "⋀a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
shows "oalist_inv_raw (map f xs)"
proof (rule oalist_inv_rawI)
show "0 ∉ snd ` set (map f xs)"
proof (simp, rule)
assume "0 ∈ snd ` f ` set xs"
then obtain a where "a ∈ set xs" and "snd (f a) = 0" by fastforce
from this(2) have "snd a = 0" by (rule assms(2))
from assms(1) have "0 ∉ snd ` set xs" by (rule oalist_inv_rawD1)
moreover from ‹a ∈ set xs› have "0 ∈ snd ` set xs" by (simp add: ‹snd a = 0›[symmetric])
ultimately show False ..
qed
next
from assms(1) have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
hence "sorted_wrt (λx y. comp (fst x) (fst y) = Lt) xs"
by (simp only: sorted_wrt_map Lt_lt_conv)
thus "sorted_wrt lt (map fst (map f xs))"
by (simp add: sorted_wrt_map Lt_lt_conv[symmetric] assms(3))
qed
lemma oalist_inv_raw_induct [consumes 1, case_names Nil Cons]:
assumes "oalist_inv_raw xs"
assumes "P []"
assumes "⋀k v xs. oalist_inv_raw ((k, v) # xs) ⟹ oalist_inv_raw xs ⟹ v ≠ 0 ⟹
(⋀k'. k' ∈ fst ` set xs ⟹ lt k k') ⟹ P xs ⟹ P ((k, v) # xs)"
shows "P xs"
using assms(1)
proof (induct xs)
case Nil
from assms(2) show ?case .
next
case (Cons x xs)
obtain k v where x: "x = (k, v)" by fastforce
from Cons(2) have "oalist_inv_raw ((k, v) # xs)" and "oalist_inv_raw xs" and "v ≠ 0" unfolding x
by (this, rule oalist_inv_raw_ConsD1, rule oalist_inv_raw_ConsD2)
moreover from Cons(2) have "lt k k'" if "k' ∈ fst ` set xs" for k' using that
unfolding x by (rule oalist_inv_raw_ConsD3)
moreover from ‹oalist_inv_raw xs› have "P xs" by (rule Cons(1))
ultimately show ?case unfolding x by (rule assms(3))
qed
subsection ‹Operations on Lists of Pairs in Context @{locale comparator}›
type_synonym (in -) ('a, 'b) comp_opt = "'a ⇒ 'b ⇒ (order option)"
definition (in -) lookup_dflt :: "('a × 'b) list ⇒ 'a ⇒ 'b::zero"
where "lookup_dflt xs k = (case map_of xs k of Some v ⇒ v | None ⇒ 0)"
text ‹@{const lookup_dflt} is only an auxiliary function needed for proving some lemmas.›
fun lookup_pair :: "('a × 'b) list ⇒ 'a ⇒ 'b::zero"
where
"lookup_pair [] x = 0"|
"lookup_pair ((k, v) # xs) x =
(case comp x k of
Lt ⇒ 0
| Eq ⇒ v
| Gt ⇒ lookup_pair xs x)"
fun update_by_pair :: "('a × 'b) ⇒ ('a × 'b) list ⇒ ('a × 'b::zero) list"
where
"update_by_pair (k, v) [] = (if v = 0 then [] else [(k, v)])"
| "update_by_pair (k, v) ((k', v') # xs) =
(case comp k k' of Lt ⇒ (if v = 0 then (k', v') # xs else (k, v) # (k', v') # xs)
| Eq ⇒ (if v = 0 then xs else (k, v) # xs)
| Gt ⇒ (k', v') # update_by_pair (k, v) xs)"
definition sort_oalist :: "('a × 'b) list ⇒ ('a × 'b::zero) list"
where "sort_oalist xs = foldr update_by_pair xs []"
fun update_by_fun_pair :: "'a ⇒ ('b ⇒ 'b) ⇒ ('a × 'b) list ⇒ ('a × 'b::zero) list"
where
"update_by_fun_pair k f [] = (let v = f 0 in if v = 0 then [] else [(k, v)])"
| "update_by_fun_pair k f ((k', v') # xs) =
(case comp k k' of Lt ⇒ (let v = f 0 in if v = 0 then (k', v') # xs else (k, v) # (k', v') # xs)
| Eq ⇒ (let v = f v' in if v = 0 then xs else (k, v) # xs)
| Gt ⇒ (k', v') # update_by_fun_pair k f xs)"
definition update_by_fun_gr_pair :: "'a ⇒ ('b ⇒ 'b) ⇒ ('a × 'b) list ⇒ ('a × 'b::zero) list"
where "update_by_fun_gr_pair k f xs =
(if xs = [] then
(let v = f 0 in if v = 0 then [] else [(k, v)])
else if comp k (fst (last xs)) = Gt then
(let v = f 0 in if v = 0 then xs else xs @ [(k, v)])
else
update_by_fun_pair k f xs
)"
fun (in -) map_pair :: "(('a × 'b) ⇒ ('a × 'c)) ⇒ ('a × 'b::zero) list ⇒ ('a × 'c::zero) list"
where
"map_pair f [] = []"
| "map_pair f (kv # xs) =
(let (k, v) = f kv; aux = map_pair f xs in if v = 0 then aux else (k, v) # aux)"
text ‹The difference between @{const List.map} and @{const map_pair} is that the latter removes
@{term 0} values, whereas the former does not.›
abbreviation (in -) map_val_pair :: "('a ⇒ 'b ⇒ 'c) ⇒ ('a × 'b::zero) list ⇒ ('a × 'c::zero) list"
where "map_val_pair f ≡ map_pair (λ(k, v). (k, f k v))"
fun map2_val_pair :: "('a ⇒ 'b ⇒ 'c ⇒ 'd) ⇒ (('a × 'b) list ⇒ ('a × 'd) list) ⇒
(('a × 'c) list ⇒ ('a × 'd) list) ⇒
('a × 'b::zero) list ⇒ ('a × 'c::zero) list ⇒ ('a × 'd::zero) list"
where
"map2_val_pair f g h xs [] = g xs"
| "map2_val_pair f g h [] ys = h ys"
| "map2_val_pair f g h ((kx, vx) # xs) ((ky, vy) # ys) =
(case comp kx ky of
Lt ⇒ (let v = f kx vx 0; aux = map2_val_pair f g h xs ((ky, vy) # ys) in if v = 0 then aux else (kx, v) # aux)
| Eq ⇒ (let v = f kx vx vy; aux = map2_val_pair f g h xs ys in if v = 0 then aux else (kx, v) # aux)
| Gt ⇒ (let v = f ky 0 vy; aux = map2_val_pair f g h ((kx, vx) # xs) ys in if v = 0 then aux else (ky, v) # aux))"
fun lex_ord_pair :: "('a ⇒ (('b, 'c) comp_opt)) ⇒ (('a × 'b::zero) list, ('a × 'c::zero) list) comp_opt"
where
"lex_ord_pair f [] [] = Some Eq"|
"lex_ord_pair f [] ((ky, vy) # ys) =
(let aux = f ky 0 vy in if aux = Some Eq then lex_ord_pair f [] ys else aux)"|
"lex_ord_pair f ((kx, vx) # xs) [] =
(let aux = f kx vx 0 in if aux = Some Eq then lex_ord_pair f xs [] else aux)"|
"lex_ord_pair f ((kx, vx) # xs) ((ky, vy) # ys) =
(case comp kx ky of
Lt ⇒ (let aux = f kx vx 0 in if aux = Some Eq then lex_ord_pair f xs ((ky, vy) # ys) else aux)
| Eq ⇒ (let aux = f kx vx vy in if aux = Some Eq then lex_ord_pair f xs ys else aux)
| Gt ⇒ (let aux = f ky 0 vy in if aux = Some Eq then lex_ord_pair f ((kx, vx) # xs) ys else aux))"
fun prod_ord_pair :: "('a ⇒ 'b ⇒ 'c ⇒ bool) ⇒ ('a × 'b::zero) list ⇒ ('a × 'c::zero) list ⇒ bool"
where
"prod_ord_pair f [] [] = True"|
"prod_ord_pair f [] ((ky, vy) # ys) = (f ky 0 vy ∧ prod_ord_pair f [] ys)"|
"prod_ord_pair f ((kx, vx) # xs) [] = (f kx vx 0 ∧ prod_ord_pair f xs [])"|
"prod_ord_pair f ((kx, vx) # xs) ((ky, vy) # ys) =
(case comp kx ky of
Lt ⇒ (f kx vx 0 ∧ prod_ord_pair f xs ((ky, vy) # ys))
| Eq ⇒ (f kx vx vy ∧ prod_ord_pair f xs ys)
| Gt ⇒ (f ky 0 vy ∧ prod_ord_pair f ((kx, vx) # xs) ys))"
text ‹@{const prod_ord_pair} is actually just a special case of @{const lex_ord_pair}, as proved below
in lemma ‹prod_ord_pair_eq_lex_ord_pair›.›
subsubsection ‹@{const lookup_pair}›
lemma lookup_pair_eq_0:
assumes "oalist_inv_raw xs"
shows "lookup_pair xs k = 0 ⟷ (k ∉ fst ` set xs)"
using assms
proof (induct xs rule: oalist_inv_raw_induct)
case Nil
show ?case by simp
next
case (Cons k' v' xs)
show ?case
proof (simp add: Cons(3) eq split: order.splits, rule, simp_all only: atomize_imp[symmetric])
assume "comp k k' = Lt"
hence "k ≠ k'" by auto
moreover have "k ∉ fst ` set xs"
proof
assume "k ∈ fst ` set xs"
hence "lt k' k" by (rule Cons(4))
with ‹comp k k' = Lt› show False by (simp add: Lt_lt_conv)
qed
ultimately show "k ≠ k' ∧ k ∉ fst ` set xs" ..
next
assume "comp k k' = Gt"
hence "k ≠ k'" by auto
thus "(lookup_pair xs k = 0) = (k ≠ k' ∧ k ∉ fst ` set xs)" by (simp add: Cons(5))
qed
qed
lemma lookup_pair_eq_value:
assumes "oalist_inv_raw xs" and "v ≠ 0"
shows "lookup_pair xs k = v ⟷ ((k, v) ∈ set xs)"
using assms(1)
proof (induct xs rule: oalist_inv_raw_induct)
case Nil
from assms(2) show ?case by simp
next
case (Cons k' v' xs)
have *: "(k', u) ∉ set xs" for u
proof
assume "(k', u) ∈ set xs"
hence "fst (k', u) ∈ fst ` set xs" by fastforce
hence "k' ∈ fst ` set xs" by simp
hence "lt k' k'" by (rule Cons(4))
thus False by (simp add: lt_of_key_order_alt[symmetric])
qed
show ?case
proof (simp add: assms(2) Cons(5) eq split: order.split, intro conjI impI)
assume "comp k k' = Lt"
show "(k, v) ∉ set xs"
proof
assume "(k, v) ∈ set xs"
hence "fst (k, v) ∈ fst ` set xs" by fastforce
hence "k ∈ fst ` set xs" by simp
hence "lt k' k" by (rule Cons(4))
with ‹comp k k' = Lt› show False by (simp add: Lt_lt_conv)
qed
qed (auto simp: *)
qed
lemma lookup_pair_eq_valueI:
assumes "oalist_inv_raw xs" and "(k, v) ∈ set xs"
shows "lookup_pair xs k = v"
proof -
from assms(2) have "v ∈ snd ` set xs" by force
moreover from assms(1) have "0 ∉ snd ` set xs" by (rule oalist_inv_rawD1)
ultimately have "v ≠ 0" by blast
with assms show ?thesis by (simp add: lookup_pair_eq_value)
qed
lemma lookup_dflt_eq_lookup_pair:
assumes "oalist_inv_raw xs"
shows "lookup_dflt xs = lookup_pair xs"
proof (rule, simp add: lookup_dflt_def split: option.split, intro conjI impI allI)
fix k
assume "map_of xs k = None"
with assms show "lookup_pair xs k = 0" by (simp add: lookup_pair_eq_0 map_of_eq_None_iff)
next
fix k v
assume "map_of xs k = Some v"
hence "(k, v) ∈ set xs" by (rule map_of_SomeD)
with assms have "lookup_pair xs k = v" by (rule lookup_pair_eq_valueI)
thus "v = lookup_pair xs k" by (rule HOL.sym)
qed
lemma lookup_pair_inj:
assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "lookup_pair xs = lookup_pair ys"
shows "xs = ys"
using assms
proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
case Nil
thus ?case
proof (induct ys rule: oalist_inv_raw_induct)
case Nil
show ?case by simp
next
case (Cons k' v' ys)
have "v' = lookup_pair ((k', v') # ys) k'" by simp
also have "... = lookup_pair [] k'" by (simp only: Cons(6))
also have "... = 0" by simp
finally have "v' = 0" .
with Cons(3) show ?case ..
qed
next
case *: (Cons k v xs)
from *(6, 7) show ?case
proof (induct ys rule: oalist_inv_raw_induct)
case Nil
have "v = lookup_pair ((k, v) # xs) k" by simp
also have "... = lookup_pair [] k" by (simp only: Nil)
also have "... = 0" by simp
finally have "v = 0" .
with *(3) show ?case ..
next
case (Cons k' v' ys)
show ?case
proof (cases "comp k k'")
case Lt
hence "¬ lt k' k" by (simp add: Lt_lt_conv)
with Cons(4) have "k ∉ fst ` set ys" by blast
moreover from Lt have "k ≠ k'" by auto
ultimately have "k ∉ fst ` set ((k', v') # ys)" by simp
hence "0 = lookup_pair ((k', v') # ys) k"
by (simp add: lookup_pair_eq_0[OF Cons(1)] del: lookup_pair.simps)
also have "... = lookup_pair ((k, v) # xs) k" by (simp only: Cons(6))
also have "... = v" by simp
finally have "v = 0" by simp
with *(3) show ?thesis ..
next
case Eq
hence "k' = k" by (simp only: eq)
have "v' = lookup_pair ((k', v') # ys) k'" by simp
also have "... = lookup_pair ((k, v) # xs) k" by (simp only: Cons(6) ‹k' = k›)
also have "... = v" by simp
finally have "v' = v" .
moreover note ‹k' = k›
moreover from Cons(2) have "xs = ys"
proof (rule *(5))
show "lookup_pair xs = lookup_pair ys"
proof
fix k0
show "lookup_pair xs k0 = lookup_pair ys k0"
proof (cases "lt k k0")
case True
hence eq: "comp k0 k = Gt"
by (simp add: Gt_lt_conv)
have "lookup_pair xs k0 = lookup_pair ((k, v) # xs) k0" by (simp add: eq)
also have "... = lookup_pair ((k, v') # ys) k0" by (simp only: Cons(6) ‹k' = k›)
also have "... = lookup_pair ys k0" by (simp add: eq)
finally show ?thesis .
next
case False
with *(4) have "k0 ∉ fst ` set xs" by blast
with *(2) have eq: "lookup_pair xs k0 = 0" by (simp add: lookup_pair_eq_0)
from False Cons(4) have "k0 ∉ fst ` set ys" unfolding ‹k' = k› by blast
with Cons(2) have "lookup_pair ys k0 = 0" by (simp add: lookup_pair_eq_0)
with eq show ?thesis by simp
qed
qed
qed
ultimately show ?thesis by simp
next
case Gt
hence "¬ lt k k'" by (simp add: Gt_lt_conv)
with *(4) have "k' ∉ fst ` set xs" by blast
moreover from Gt have "k' ≠ k" by auto
ultimately have "k' ∉ fst ` set ((k, v) # xs)" by simp
hence "0 = lookup_pair ((k, v) # xs) k'"
by (simp add: lookup_pair_eq_0[OF *(1)] del: lookup_pair.simps)
also have "... = lookup_pair ((k', v') # ys) k'" by (simp only: Cons(6))
also have "... = v'" by simp
finally have "v' = 0" by simp
with Cons(3) show ?thesis ..
qed
qed
qed
lemma lookup_pair_tl:
assumes "oalist_inv_raw xs"
shows "lookup_pair (tl xs) k = (if (∀k'∈fst ` set xs. le k k') then 0 else lookup_pair xs k)"
proof -
from assms have 1: "oalist_inv_raw (tl xs)" by (rule oalist_inv_raw_tl)
show ?thesis
proof (split if_split, intro conjI impI)
assume *: "∀x∈fst ` set xs. le k x"
show "lookup_pair (tl xs) k = 0"
proof (simp add: lookup_pair_eq_0[OF 1], rule)
assume k_in: "k ∈ fst ` set (tl xs)"
hence "xs ≠ []" by auto
then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
have "k' ∈ fst ` set xs" unfolding xs by fastforce
with * have "le k k'" ..
from assms have "oalist_inv_raw ((k', v') # ys)" by (simp only: xs)
moreover from k_in have "k ∈ fst ` set ys" by (simp add: xs)
ultimately have "lt k' k" by (rule oalist_inv_raw_ConsD3)
with ‹le k k'› show False by simp
qed
next
assume "¬ (∀k'∈fst ` set xs. le k k')"
hence "∃x∈fst ` set xs. ¬ le k x" by simp
then obtain k'' where k''_in: "k'' ∈ fst ` set xs" and "¬ le k k''" ..
from this(2) have "lt k'' k" by simp
from k''_in have "xs ≠ []" by auto
then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
from k''_in have "k'' = k' ∨ k'' ∈ fst ` set ys" by (simp add: xs)
hence "lt k' k"
proof
assume "k'' = k'"
with ‹lt k'' k› show ?thesis by simp
next
from assms have "oalist_inv_raw ((k', v') # ys)" by (simp only: xs)
moreover assume "k'' ∈ fst ` set ys"
ultimately have "lt k' k''" by (rule oalist_inv_raw_ConsD3)
thus ?thesis using ‹lt k'' k› by (rule less_trans)
qed
hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
thus "lookup_pair (tl xs) k = lookup_pair xs k" by (simp add: xs lt_of_key_order_alt)
qed
qed
lemma lookup_pair_tl':
assumes "oalist_inv_raw xs"
shows "lookup_pair (tl xs) k = (if k = fst (hd xs) then 0 else lookup_pair xs k)"
proof -
from assms have 1: "oalist_inv_raw (tl xs)" by (rule oalist_inv_raw_tl)
show ?thesis
proof (split if_split, intro conjI impI)
assume k: "k = fst (hd xs)"
show "lookup_pair (tl xs) k = 0"
proof (simp add: lookup_pair_eq_0[OF 1], rule)
assume k_in: "k ∈ fst ` set (tl xs)"
hence "xs ≠ []" by auto
then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
from assms have "oalist_inv_raw ((k', v') # ys)" by (simp only: xs)
moreover from k_in have "k' ∈ fst ` set ys" by (simp add: k xs)
ultimately have "lt k' k'" by (rule oalist_inv_raw_ConsD3)
thus False by simp
qed
next
assume "k ≠ fst (hd xs)"
show "lookup_pair (tl xs) k = lookup_pair xs k"
proof (cases "xs = []")
case True
show ?thesis by (simp add: True)
next
case False
then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
show ?thesis
proof (simp add: xs eq Lt_lt_conv split: order.split, intro conjI impI)
from ‹k ≠ fst (hd xs)› have "k ≠ k'" by (simp add: xs)
moreover assume "k = k'"
ultimately show "lookup_pair ys k' = v'" ..
next
assume "lt k k'"
from assms have "oalist_inv_raw ys" unfolding xs by (rule oalist_inv_raw_ConsD1)
moreover have "k ∉ fst ` set ys"
proof
assume "k ∈ fst ` set ys"
with assms have "lt k' k" unfolding xs by (rule oalist_inv_raw_ConsD3)
with ‹lt k k'› show False by simp
qed
ultimately show "lookup_pair ys k = 0" by (simp add: lookup_pair_eq_0)
qed
qed
qed
qed
lemma lookup_pair_filter:
assumes "oalist_inv_raw xs"
shows "lookup_pair (filter P xs) k = (let v = lookup_pair xs k in if P (k, v) then v else 0)"
using assms
proof (induct xs rule: oalist_inv_raw_induct)
case Nil
show ?case by simp
next
case (Cons k' v' xs)
show ?case
proof (simp add: Cons(5) Let_def eq split: order.split, intro conjI impI)
show "lookup_pair xs k' = 0"
proof (simp add: lookup_pair_eq_0 Cons(2), rule)
assume "k' ∈ fst ` set xs"
hence "lt k' k'" by (rule Cons(4))
thus False by simp
qed
next
assume "comp k k' = Lt"
hence "lt k k'" by (simp only: Lt_lt_conv)
show "lookup_pair xs k = 0"
proof (simp add: lookup_pair_eq_0 Cons(2), rule)
assume "k ∈ fst ` set xs"
hence "lt k' k" by (rule Cons(4))
with ‹lt k k'› show False by simp
qed
qed
qed
lemma lookup_pair_map:
assumes "oalist_inv_raw xs"
and "⋀k'. snd (f (k', 0)) = 0"
and "⋀a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
shows "lookup_pair (map f xs) (fst (f (k, v))) = snd (f (k, lookup_pair xs k))"
using assms(1)
proof (induct xs rule: oalist_inv_raw_induct)
case Nil
show ?case by (simp add: assms(2))
next
case (Cons k' v' xs)
obtain k'' v'' where f: "f (k', v') = (k'', v'')" by fastforce
have "comp k k' = comp (fst (f (k, v))) (fst (f (k', v')))"
by (simp add: assms(3))
also have "... = comp (fst (f (k, v))) k''" by (simp add: f)
finally have eq0: "comp k k' = comp (fst (f (k, v))) k''" .
show ?case
proof (simp add: assms(2) split: order.split, intro conjI impI, simp add: eq)
assume "k = k'"
hence "lookup_pair (f (k', v') # map f xs) (fst (f (k', v))) =
lookup_pair (f (k', v') # map f xs) (fst (f (k, v)))" by simp
also have "... = snd (f (k', v'))" by (simp add: f eq0[symmetric], simp add: ‹k = k'›)
finally show "lookup_pair (f (k', v') # map f xs) (fst (f (k', v))) = snd (f (k', v'))" .
qed (simp_all add: f eq0 Cons(5))
qed
lemma lookup_pair_Cons:
assumes "oalist_inv_raw ((k, v) # xs)"
shows "lookup_pair ((k, v) # xs) k0 = (if k = k0 then v else lookup_pair xs k0)"
proof (simp add: eq split: order.split, intro impI)
assume "comp k0 k = Lt"
from assms have inv: "oalist_inv_raw xs" by (rule oalist_inv_raw_ConsD1)
show "lookup_pair xs k0 = 0"
proof (simp only: lookup_pair_eq_0[OF inv], rule)
assume "k0 ∈ fst ` set xs"
with assms have "lt k k0" by (rule oalist_inv_raw_ConsD3)
with ‹comp k0 k = Lt› show False by (simp add: Lt_lt_conv)
qed
qed
lemma lookup_pair_single: "lookup_pair [(k, v)] k0 = (if k = k0 then v else 0)"
by (simp add: eq split: order.split)
subsubsection ‹@{const update_by_pair}›
lemma set_update_by_pair_subset: "set (update_by_pair kv xs) ⊆ insert kv (set xs)"
proof (induct xs arbitrary: kv)
case Nil
obtain k v where kv: "kv = (k, v)" by fastforce
thus ?case by simp
next
case (Cons x xs)
obtain k' v' where x: "x = (k', v')" by fastforce
obtain k v where kv: "kv = (k, v)" by fastforce
have 1: "set xs ⊆ insert a (insert b (set xs))" for a b by auto
have 2: "set (update_by_pair kv xs) ⊆ insert kv (insert (k', v') (set xs))" for kv
using Cons by blast
show ?case by (simp add: x kv 1 2 split: order.split)
qed
lemma update_by_pair_sorted:
assumes "sorted_wrt lt (map fst xs)"
shows "sorted_wrt lt (map fst (update_by_pair kv xs))"
using assms
proof (induct xs arbitrary: kv)
case Nil
obtain k v where kv: "kv = (k, v)" by fastforce
thus ?case by simp
next
case (Cons x xs)
obtain k' v' where x: "x = (k', v')" by fastforce
obtain k v where kv: "kv = (k, v)" by fastforce
from Cons(2) have 1: "sorted_wrt lt (k' # (map fst xs))" by (simp add: x)
hence 2: "sorted_wrt lt (map fst xs)" using sorted_wrt.elims(3) by fastforce
hence 3: "sorted_wrt lt (map fst (update_by_pair (k, u) xs))" for u by (rule Cons(1))
have 4: "sorted_wrt lt (k' # map fst (update_by_pair (k, u) xs))"
if *: "comp k k' = Gt" for u
proof (simp, intro conjI ballI)
fix y
assume "y ∈ set (update_by_pair (k, u) xs)"
also from set_update_by_pair_subset have "... ⊆ insert (k, u) (set xs)" .
finally have "y = (k, u) ∨ y ∈ set xs" by simp
thus "lt k' (fst y)"
proof
assume "y = (k, u)"
hence "fst y = k" by simp
with * show ?thesis by (simp only: Gt_lt_conv)
next
from 1 have 5: "∀y ∈ fst ` set xs. lt k' y" by simp
assume "y ∈ set xs"
hence "fst y ∈ fst ` set xs" by simp
with 5 show ?thesis ..
qed
qed (fact 3)
show ?case
by (simp add: kv x 1 2 4 sorted_wrt2 split: order.split del: sorted_wrt.simps,
intro conjI impI, simp add: 1 eq del: sorted_wrt.simps, simp add: Lt_lt_conv)
qed
lemma update_by_pair_not_0:
assumes "0 ∉ snd ` set xs"
shows "0 ∉ snd ` set (update_by_pair kv xs)"
using assms
proof (induct xs arbitrary: kv)
case Nil
obtain k v where kv: "kv = (k, v)" by fastforce
thus ?case by simp
next
case (Cons x xs)
obtain k' v' where x: "x = (k', v')" by fastforce
obtain k v where kv: "kv = (k, v)" by fastforce
from Cons(2) have 1: "v' ≠ 0" and 2: "0 ∉ snd ` set xs" by (auto simp: x)
from 2 have 3: "0 ∉ snd ` set (update_by_pair (k, u) xs)" for u by (rule Cons(1))
show ?case by (auto simp: kv x 1 2 3 split: order.split)
qed
corollary oalist_inv_raw_update_by_pair:
assumes "oalist_inv_raw xs"
shows "oalist_inv_raw (update_by_pair kv xs)"
proof (rule oalist_inv_rawI)
from assms have "0 ∉ snd ` set xs" by (rule oalist_inv_rawD1)
thus "0 ∉ snd ` set (update_by_pair kv xs)" by (rule update_by_pair_not_0)
next
from assms have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
thus "sorted_wrt lt (map fst (update_by_pair kv xs))" by (rule update_by_pair_sorted)
qed
lemma update_by_pair_less:
assumes "v ≠ 0" and "xs = [] ∨ comp k (fst (hd xs)) = Lt"
shows "update_by_pair (k, v) xs = (k, v) # xs"
using assms(2)
proof (induct xs)
case Nil
from assms(1) show ?case by simp
next
case (Cons x xs)
obtain k' v' where x: "x = (k', v')" by fastforce
from Cons(2) have "comp k k' = Lt" by (simp add: x)
with assms(1) show ?case by (simp add: x)
qed
lemma lookup_pair_update_by_pair:
assumes "oalist_inv_raw xs"
shows "lookup_pair (update_by_pair (k1, v) xs) k2 = (if k1 = k2 then v else lookup_pair xs k2)"
using assms
proof (induct xs arbitrary: v rule: oalist_inv_raw_induct)
case Nil
show ?case by (simp split: order.split, simp add: eq)
next
case (Cons k' v' xs)
show ?case
proof (split if_split, intro conjI impI)
assume "k1 = k2"
with Cons(5) have eq0: "lookup_pair (update_by_pair (k2, u) xs) k2 = u" for u
by (simp del: update_by_pair.simps)
show "lookup_pair (update_by_pair (k1, v) ((k', v') # xs)) k2 = v"
proof (simp add: ‹k1 = k2› eq0 split: order.split, intro conjI impI)
assume "comp k2 k' = Eq"
hence "¬ lt k' k2" by (simp add: eq)
with Cons(4) have "k2 ∉ fst ` set xs" by auto
thus "lookup_pair xs k2 = 0" using Cons(2) by (simp add: lookup_pair_eq_0)
qed
next
assume "k1 ≠ k2"
with Cons(5) have eq0: "lookup_pair (update_by_pair (k1, u) xs) k2 = lookup_pair xs k2" for u
by (simp del: update_by_pair.simps)
have *: "lookup_pair xs k2 = 0" if "lt k2 k'"
proof -
from ‹lt k2 k'› have "¬ lt k' k2" by auto
with Cons(4) have "k2 ∉ fst ` set xs" by auto
thus "lookup_pair xs k2 = 0" using Cons(2) by (simp add: lookup_pair_eq_0)
qed
show "lookup_pair (update_by_pair (k1, v) ((k', v') # xs)) k2 = lookup_pair ((k', v') # xs) k2"
by (simp add: ‹k1 ≠ k2› eq0 split: order.split,
auto intro: * simp: ‹k1 ≠ k2›[symmetric] eq Gt_lt_conv Lt_lt_conv)
qed
qed
corollary update_by_pair_id:
assumes "oalist_inv_raw xs" and "lookup_pair xs k = v"
shows "update_by_pair (k, v) xs = xs"
proof (rule lookup_pair_inj, rule oalist_inv_raw_update_by_pair)
show "lookup_pair (update_by_pair (k, v) xs) = lookup_pair xs"
proof
fix k0
from assms(2) show "lookup_pair (update_by_pair (k, v) xs) k0 = lookup_pair xs k0"
by (auto simp: lookup_pair_update_by_pair[OF assms(1)])
qed
qed fact+
lemma set_update_by_pair:
assumes "oalist_inv_raw xs" and "v ≠ 0"
shows "set (update_by_pair (k, v) xs) = insert (k, v) (set xs - range (Pair k))" (is "?A = ?B")
proof (rule set_eqI)
fix x::"'a × 'b"
obtain k' v' where x: "x = (k', v')" by fastforce
from assms(1) have inv: "oalist_inv_raw (update_by_pair (k, v) xs)"
by (rule oalist_inv_raw_update_by_pair)
show "(x ∈ ?A) ⟷ (x ∈ ?B)"
proof (cases "v' = 0")
case True
have "0 ∉ snd ` set (update_by_pair (k, v) xs)" and "0 ∉ snd ` set xs"
by (rule oalist_inv_rawD1, fact)+
hence "(k', 0) ∉ set (update_by_pair (k, v) xs)" and "(k', 0) ∉ set xs"
using image_iff by fastforce+
thus ?thesis by (simp add: x True assms(2))
next
case False
show ?thesis
by (auto simp: x lookup_pair_eq_value[OF inv False, symmetric] lookup_pair_eq_value[OF assms(1) False]
lookup_pair_update_by_pair[OF assms(1)])
qed
qed
lemma set_update_by_pair_zero:
assumes "oalist_inv_raw xs"
shows "set (update_by_pair (k, 0) xs) = set xs - range (Pair k)" (is "?A = ?B")
proof (rule set_eqI)
fix x::"'a × 'b"
obtain k' v' where x: "x = (k', v')" by fastforce
from assms(1) have inv: "oalist_inv_raw (update_by_pair (k, 0) xs)"
by (rule oalist_inv_raw_update_by_pair)
show "(x ∈ ?A) ⟷ (x ∈ ?B)"
proof (cases "v' = 0")
case True
have "0 ∉ snd ` set (update_by_pair (k, 0) xs)" and "0 ∉ snd ` set xs"
by (rule oalist_inv_rawD1, fact)+
hence "(k', 0) ∉ set (update_by_pair (k, 0) xs)" and "(k', 0) ∉ set xs"
using image_iff by fastforce+
thus ?thesis by (simp add: x True)
next
case False
show ?thesis
by (auto simp: x lookup_pair_eq_value[OF inv False, symmetric] lookup_pair_eq_value[OF assms False]
lookup_pair_update_by_pair[OF assms] False)
qed
qed
subsubsection ‹@{const update_by_fun_pair} and @{const update_by_fun_gr_pair}›
lemma update_by_fun_pair_eq_update_by_pair:
assumes "oalist_inv_raw xs"
shows "update_by_fun_pair k f xs = update_by_pair (k, f (lookup_pair xs k)) xs"
using assms by (induct xs rule: oalist_inv_raw_induct, simp, simp split: order.split)
corollary oalist_inv_raw_update_by_fun_pair:
assumes "oalist_inv_raw xs"
shows "oalist_inv_raw (update_by_fun_pair k f xs)"
unfolding update_by_fun_pair_eq_update_by_pair[OF assms] using assms by (rule oalist_inv_raw_update_by_pair)
corollary lookup_pair_update_by_fun_pair:
assumes "oalist_inv_raw xs"
shows "lookup_pair (update_by_fun_pair k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_pair xs k2)"
by (simp add: update_by_fun_pair_eq_update_by_pair[OF assms] lookup_pair_update_by_pair[OF assms])
lemma update_by_fun_pair_gr:
assumes "oalist_inv_raw xs" and "xs = [] ∨ comp k (fst (last xs)) = Gt"
shows "update_by_fun_pair k f xs = xs @ (if f 0 = 0 then [] else [(k, f 0)])"
using assms
proof (induct xs rule: oalist_inv_raw_induct)
case Nil
show ?case by simp
next
case (Cons k' v' xs)
from Cons(6) have 1: "comp k (fst (last ((k', v') # xs))) = Gt" by simp
have eq1: "comp k k' = Gt"
proof (cases "xs = []")
case True
with 1 show ?thesis by simp
next
case False
have "lt k' (fst (last xs))" by (rule Cons(4), simp add: False)
from False 1 have "comp k (fst (last xs)) = Gt" by simp
moreover from ‹lt k' (fst (last xs))› have "comp (fst (last xs)) k' = Gt"
by (simp add: Gt_lt_conv)
ultimately show ?thesis
by (meson Gt_lt_conv less_trans Lt_lt_conv[symmetric])
qed
have eq2: "update_by_fun_pair k f xs = xs @ (if f 0 = 0 then [] else [(k, f 0)])"
proof (rule Cons(5), simp only: disj_commute[of "xs = []"], rule disjCI)
assume "xs ≠ []"
with 1 show "comp k (fst (last xs)) = Gt" by simp
qed
show ?case by (simp split: order.split add: Let_def eq1 eq2)
qed
corollary update_by_fun_gr_pair_eq_update_by_fun_pair:
assumes "oalist_inv_raw xs"
shows "update_by_fun_gr_pair k f xs = update_by_fun_pair k f xs"
by (simp add: update_by_fun_gr_pair_def Let_def update_by_fun_pair_gr[OF assms] split: order.split)
corollary oalist_inv_raw_update_by_fun_gr_pair:
assumes "oalist_inv_raw xs"
shows "oalist_inv_raw (update_by_fun_gr_pair k f xs)"
unfolding update_by_fun_pair_eq_update_by_pair[OF assms] update_by_fun_gr_pair_eq_update_by_fun_pair[OF assms]
using assms by (rule oalist_inv_raw_update_by_pair)
corollary lookup_pair_update_by_fun_gr_pair:
assumes "oalist_inv_raw xs"
shows "lookup_pair (update_by_fun_gr_pair k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_pair xs k2)"
by (simp add: update_by_fun_pair_eq_update_by_pair[OF assms]
update_by_fun_gr_pair_eq_update_by_fun_pair[OF assms] lookup_pair_update_by_pair[OF assms])
subsubsection ‹@{const map_pair}›
lemma map_pair_cong:
assumes "⋀kv. kv ∈ set xs ⟹ f kv = g kv"
shows "map_pair f xs = map_pair g xs"
using assms
proof (induct xs)
case Nil
show ?case by simp
next
case (Cons x xs)
have "f x = g x" by (rule Cons(2), simp)
moreover have "map_pair f xs = map_pair g xs" by (rule Cons(1), rule Cons(2), simp)
ultimately show ?case by simp
qed
lemma map_pair_subset: "set (map_pair f xs) ⊆ f ` set xs"
proof (induct xs rule: map_pair.induct)
case (1 f)
show ?case by simp
next
case (2 f kv xs)
obtain k v where f: "f kv = (k, v)" by fastforce
from f[symmetric] refl have *: "set (map_pair f xs) ⊆ f ` set xs" by (rule 2)
show ?case by (simp add: f Let_def, intro conjI impI subset_insertI2 *)
qed
lemma oalist_inv_raw_map_pair:
assumes "oalist_inv_raw xs"
and "⋀a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
shows "oalist_inv_raw (map_pair f xs)"
using assms(1)
proof (induct xs rule: oalist_inv_raw_induct)
case Nil
from oalist_inv_raw_Nil show ?case by simp
next
case (Cons k v xs)
obtain k' v' where f: "f (k, v) = (k', v')" by fastforce
show ?case
proof (simp add: f Let_def Cons(5), rule)
assume "v' ≠ 0"
with Cons(5) show "oalist_inv_raw ((k', v') # map_pair f xs)"
proof (rule oalist_inv_raw_ConsI)
assume "map_pair f xs ≠ []"
hence "hd (map_pair f xs) ∈ set (map_pair f xs)" by simp
also have "... ⊆ f ` set xs" by (fact map_pair_subset)
finally obtain x where "x ∈ set xs" and eq: "hd (map_pair f xs) = f x" ..
from this(1) have "fst x ∈ fst ` set xs" by fastforce
hence "lt k (fst x)" by (rule Cons(4))
hence "lt (fst (f (k, v))) (fst (f x))"
by (simp add: Lt_lt_conv[symmetric] assms(2))
thus "lt k' (fst (hd (map_pair f xs)))" by (simp add: f eq)
qed
qed
qed
lemma lookup_pair_map_pair:
assumes "oalist_inv_raw xs" and "snd (f (k, 0)) = 0"
and "⋀a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
shows "lookup_pair (map_pair f xs) (fst (f (k, v))) = snd (f (k, lookup_pair xs k))"
using assms(1)
proof (induct xs rule: oalist_inv_raw_induct)
case Nil
show ?case by (simp add: assms(2))
next
case (Cons k' v' xs)
obtain k'' v'' where f: "f (k', v') = (k'', v'')" by fastforce
have "comp (fst (f (k, v))) k'' = comp (fst (f (k, v))) (fst (f (k', v')))"
by (simp add: f)
also have "... = comp k k'"
by (simp add: assms(3))
finally have eq0: "comp (fst (f (k, v))) k'' = comp k k'" .
have *: "lookup_pair xs k = 0" if "comp k k' ≠ Gt"
proof (simp add: lookup_pair_eq_0[OF Cons(2)], rule)
assume "k ∈ fst ` set xs"
hence "lt k' k" by (rule Cons(4))
hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
with ‹comp k k' ≠ Gt› show False ..
qed
show ?case
proof (simp add: assms(2) f Let_def eq0 Cons(5) split: order.split, intro conjI impI)
assume "comp k k' = Lt"
hence "comp k k' ≠ Gt" by simp
hence "lookup_pair xs k = 0" by (rule *)
thus "snd (f (k, lookup_pair xs k)) = 0" by (simp add: assms(2))
next
assume "v'' = 0"
assume "comp k k' = Eq"
hence "k = k'" and "comp k k' ≠ Gt" by (simp only: eq, simp)
from this(2) have "lookup_pair xs k = 0" by (rule *)
hence "snd (f (k, lookup_pair xs k)) = 0" by (simp add: assms(2))
also have "... = snd (f (k, v'))" by (simp add: ‹k = k'› f ‹v'' = 0›)
finally show "snd (f (k, lookup_pair xs k)) = snd (f (k, v'))" .
qed (simp add: f eq)
qed
lemma lookup_dflt_map_pair:
assumes "distinct (map fst xs)" and "snd (f (k, 0)) = 0"
and "⋀a b. (fst (f a) = fst (f b)) ⟷ (fst a = fst b)"
shows "lookup_dflt (map_pair f xs) (fst (f (k, v))) = snd (f (k, lookup_dflt xs k))"
using assms(1)
proof (induct xs)
case Nil
show ?case by (simp add: lookup_dflt_def assms(2))
next
case (Cons x xs)
obtain k' v' where x: "x = (k', v')" by fastforce
obtain k'' v'' where f: "f (k', v') = (k'', v'')" by fastforce
from Cons(2) have "distinct (map fst xs)" and "k' ∉ fst ` set xs" by (simp_all add: x)
from this(1) have eq1: "lookup_dflt (map_pair f xs) (fst (f (k, v))) = snd (f (k, lookup_dflt xs k))"
by (rule Cons(1))
have eq2: "lookup_dflt ((a, b) # ys) c = (if c = a then b else lookup_dflt ys c)"
for a b c and ys::"('b × 'e::zero) list" by (simp add: lookup_dflt_def map_of_Cons_code)
from ‹k' ∉ fst ` set xs› have "map_of xs k' = None" by (simp add: map_of_eq_None_iff)
hence eq3: "lookup_dflt xs k' = 0" by (simp add: lookup_dflt_def)
show ?case
proof (simp add: f Let_def x eq1 eq2 eq3, intro conjI impI)
assume "k = k'"
hence "snd (f (k', 0)) = snd (f (k, 0))" by simp
also have "... = 0" by (fact assms(2))
finally show "snd (f (k', 0)) = 0" .
next
assume "fst (f (k', v)) ≠ k''"
hence "fst (f (k', v)) ≠ fst (f (k', v'))" by (simp add: f)
thus "snd (f (k', 0)) = v''" by (simp add: assms(3))
next
assume "k ≠ k'"
assume "fst (f (k, v)) = k''"
also have "... = fst (f (k', v'))" by (simp add: f)
finally have "k = k'" by (simp add: assms(3))
with ‹k ≠ k'› show "v'' = snd (f (k, lookup_dflt xs k))" ..
qed
qed
lemma distinct_map_pair:
assumes "distinct (map fst xs)" and "⋀a b. fst (f a) = fst (f b) ⟹ fst a = fst b"
shows "distinct (map fst (map_pair f xs))"
using assms(1)
proof (induct xs)
case Nil
show ?case by simp
next
case (Cons x xs)
obtain k v where x: "x = (k, v)" by fastforce
obtain k' v' where f: "f (k, v) = (k', v')" by fastforce
from Cons(2) have "distinct (map fst xs)" and "k ∉ fst ` set xs" by (simp_all add: x)
from this(1) have 1: "distinct (map fst (map_pair f xs))" by (rule Cons(1))
show ?case
proof (simp add: x f Let_def 1, intro impI notI)
assume "v' ≠ 0"
assume "k' ∈ fst ` set (map_pair f xs)"
then obtain y where "y ∈ set (map_pair f xs)" and "k' = fst y" ..
from this(1) map_pair_subset have "y ∈ f ` set xs" ..
then obtain z where "z ∈ set xs" and "y = f z" ..
from this(2) have "fst (f z) = k'" by (simp add: ‹k' = fst y›)
also have "... = fst (f (k, v))" by (simp add: f)
finally have "fst z = fst (k, v)" by (rule assms(2))
also have "... = k" by simp
finally have "k ∈ fst ` set xs" using ‹z ∈ set xs› by blast
with ‹k ∉ fst ` set xs› show False ..
qed
qed
lemma map_val_pair_cong:
assumes "⋀k v. (k, v) ∈ set xs ⟹ f k v = g k v"
shows "map_val_pair f xs = map_val_pair g xs"
proof (rule map_pair_cong)
fix kv
assume "kv ∈ set xs"
moreover obtain k v where "kv = (k, v)" by fastforce
ultimately show "(case kv of (k, v) ⇒ (k, f k v)) = (case kv of (k, v) ⇒ (k, g k v))"
by (simp add: assms)
qed
lemma oalist_inv_raw_map_val_pair:
assumes "oalist_inv_raw xs"
shows "oalist_inv_raw (map_val_pair f xs)"
by (rule oalist_inv_raw_map_pair, fact assms, auto)
lemma lookup_pair_map_val_pair:
assumes "oalist_inv_raw xs" and "f k 0 = 0"
shows "lookup_pair (map_val_pair f xs) k = f k (lookup_pair xs k)"
proof -
let ?f = "λ(k', v'). (k', f k' v')"
have "lookup_pair (map_val_pair f xs) k = lookup_pair (map_val_pair f xs) (fst (?f (k, 0)))"
by simp
also have "... = snd (?f (k, local.lookup_pair xs k))"
by (rule lookup_pair_map_pair, fact assms(1), auto simp: assms(2))
also have "... = f k (lookup_pair xs k)" by simp
finally show ?thesis .
qed
lemma map_pair_id:
assumes "oalist_inv_raw xs"
shows "map_pair id xs = xs"
using assms
proof (induct xs rule: oalist_inv_raw_induct)
case Nil
show ?case by simp
next
case (Cons k v xs')
show ?case by (simp add: Let_def Cons(3, 5) id_def[symmetric])
qed
subsubsection ‹@{const map2_val_pair}›
definition map2_val_compat :: "(('a × 'b::zero) list ⇒ ('a × 'c::zero) list) ⇒ bool"
where "map2_val_compat f ⟷ (∀zs. (oalist_inv_raw zs ⟶
(oalist_inv_raw (f zs) ∧ fst ` set (f zs) ⊆ fst ` set zs)))"
lemma map2_val_compatI:
assumes "⋀zs. oalist_inv_raw zs ⟹ oalist_inv_raw (f zs)"
and "⋀zs. oalist_inv_raw zs ⟹ fst ` set (f zs) ⊆ fst ` set zs"
shows "map2_val_compat f"
unfolding map2_val_compat_def using assms by blast
lemma map2_val_compatD1:
assumes "map2_val_compat f" and "oalist_inv_raw zs"
shows "oalist_inv_raw (f zs)"
using assms unfolding map2_val_compat_def by blast
lemma map2_val_compatD2:
assumes "map2_val_compat f" and "oalist_inv_raw zs"
shows "fst ` set (f zs) ⊆ fst ` set zs"
using assms unfolding map2_val_compat_def by blast
lemma map2_val_compat_Nil:
assumes "map2_val_compat (f::('a × 'b::zero) list ⇒ ('a × 'c::zero) list)"
shows "f [] = []"
proof -
from assms oalist_inv_raw_Nil have "fst ` set (f []) ⊆ fst ` set ([]::('a × 'b) list)"
by (rule map2_val_compatD2)
thus ?thesis by simp
qed
lemma map2_val_compat_id: "map2_val_compat id"
by (rule map2_val_compatI, auto)
lemma map2_val_compat_map_val_pair: "map2_val_compat (map_val_pair f)"
proof (rule map2_val_compatI, erule oalist_inv_raw_map_val_pair)
fix zs
from map_pair_subset image_iff show "fst ` set (map_val_pair f zs) ⊆ fst ` set zs" by fastforce
qed
lemma fst_map2_val_pair_subset:
assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
assumes "map2_val_compat g" and "map2_val_compat h"
shows "fst ` set (map2_val_pair f g h xs ys) ⊆ fst ` set xs ∪ fst ` set ys"
using assms
proof (induct f g h xs ys rule: map2_val_pair.induct)
case (1 f g h xs)
show ?case by (simp, rule map2_val_compatD2, fact+)
next
case (2 f g h v va)
show ?case by (simp del: set_simps(2), rule map2_val_compatD2, fact+)
next
case (3 f g h kx vx xs ky vy ys)
from 3(4) have "oalist_inv_raw xs" by (rule oalist_inv_raw_ConsD1)
from 3(5) have "oalist_inv_raw ys" by (rule oalist_inv_raw_ConsD1)
show ?case
proof (simp split: order.split, intro conjI impI)
assume "comp kx ky = Lt"
hence "fst ` set (map2_val_pair f g h xs ((ky, vy) # ys)) ⊆ fst ` set xs ∪ fst ` set ((ky, vy) # ys)"
using refl ‹oalist_inv_raw xs› 3(5, 6, 7) by (rule 3(2))
thus "fst ` set (let v = f kx vx 0; aux = map2_val_pair f g h xs ((ky, vy) # ys)
in if v = 0 then aux else (kx, v) # aux)
⊆ insert ky (insert kx (fst ` set xs ∪ fst ` set ys))" by (auto simp: Let_def)
next
assume "comp kx ky = Eq"
hence "fst ` set (map2_val_pair f g h xs ys) ⊆ fst ` set xs ∪ fst ` set ys"
using refl ‹oalist_inv_raw xs› ‹oalist_inv_raw ys› 3(6, 7) by (rule 3(1))
thus "fst ` set (let v = f kx vx vy; aux = map2_val_pair f g h xs ys in if v = 0 then aux else (kx, v) # aux)
⊆ insert ky (insert kx (fst ` set xs ∪ fst ` set ys))" by (auto simp: Let_def)
next
assume "comp kx ky = Gt"
hence "fst ` set (map2_val_pair f g h ((kx, vx) # xs) ys) ⊆ fst ` set ((kx, vx) # xs) ∪ fst ` set ys"
using refl 3(4) ‹oalist_inv_raw ys› 3(6, 7) by (rule 3(3))
thus "fst ` set (let v = f ky 0 vy; aux = map2_val_pair f g h ((kx, vx) # xs) ys
in if v = 0 then aux else (ky, v) # aux)
⊆ insert ky (insert kx (fst ` set xs ∪ fst ` set ys))" by (auto simp: Let_def)
qed
qed
lemma oalist_inv_raw_map2_val_pair:
assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
assumes "map2_val_compat g" and "map2_val_compat h"
shows "oalist_inv_raw (map2_val_pair f g h xs ys)"
using assms(1, 2)
proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
case Nil
show ?case
proof (cases ys)
case Nil
show ?thesis by (simp add: Nil, rule map2_val_compatD1, fact assms(3), fact oalist_inv_raw_Nil)
next
case (Cons y ys')
show ?thesis by (simp add: Cons, rule map2_val_compatD1, fact assms(4), simp only: Cons[symmetric], fact Nil)
qed
next
case *: (Cons k v xs)
from *(6) show ?case
proof (induct ys rule: oalist_inv_raw_induct)
case Nil
show ?case by (simp, rule map2_val_compatD1, fact assms(3), fact *(1))
next
case (Cons k' v' ys)
show ?case
proof (simp split: order.split, intro conjI impI)
assume "comp k k' = Lt"
hence 0: "lt k k'" by (simp only: Lt_lt_conv)
from Cons(1) have 1: "oalist_inv_raw (map2_val_pair f g h xs ((k', v') # ys))" by (rule *(5))
show "oalist_inv_raw (let v = f k v 0; aux = map2_val_pair f g h xs ((k', v') # ys)
in if v = 0 then aux else (k, v) # aux)"
proof (simp add: Let_def, intro conjI impI)
assume "f k v 0 ≠ 0"
with 1 show "oalist_inv_raw ((k, f k v 0) # map2_val_pair f g h xs ((k', v') # ys))"
proof (rule oalist_inv_raw_ConsI)
define k0 where "k0 = fst (hd (local.map2_val_pair f g h xs ((k', v') # ys)))"
assume "map2_val_pair f g h xs ((k', v') # ys) ≠ []"
hence "k0 ∈ fst ` set (map2_val_pair f g h xs ((k', v') # ys))" by (simp add: k0_def)
also from *(2) Cons(1) assms(3, 4) have "... ⊆ fst ` set xs ∪ fst ` set ((k', v') # ys)"
by (rule fst_map2_val_pair_subset)
finally have "k0 ∈ fst ` set xs ∨ k0 = k' ∨ k0 ∈ fst ` set ys" by auto
thus "lt k k0"
proof (elim disjE)
assume "k0 = k'"
with 0 show ?thesis by simp
next
assume "k0 ∈ fst ` set ys"
hence "lt k' k0" by (rule Cons(4))
with 0 show ?thesis by (rule less_trans)
qed (rule *(4))
qed
qed (rule 1)
next
assume "comp k k' = Eq"
hence "k = k'" by (simp only: eq)
from Cons(2) have 1: "oalist_inv_raw (map2_val_pair f g h xs ys)" by (rule *(5))
show "oalist_inv_raw (let v = f k v v'; aux = map2_val_pair f g h xs ys in if v = 0 then aux else (k, v) # aux)"
proof (simp add: Let_def, intro conjI impI)
assume "f k v v' ≠ 0"
with 1 show "oalist_inv_raw ((k, f k v v') # map2_val_pair f g h xs ys)"
proof (rule oalist_inv_raw_ConsI)
define k0 where "k0 = fst (hd (map2_val_pair f g h xs ys))"
assume "map2_val_pair f g h xs ys ≠ []"
hence "k0 ∈ fst ` set (map2_val_pair f g h xs ys)" by (simp add: k0_def)
also from *(2) Cons(2) assms(3, 4) have "... ⊆ fst ` set xs ∪ fst ` set ys"
by (rule fst_map2_val_pair_subset)
finally show "lt k k0"
proof
assume "k0 ∈ fst ` set ys"
hence "lt k' k0" by (rule Cons(4))
thus ?thesis by (simp only: ‹k = k'›)
qed (rule *(4))
qed
qed (rule 1)
next
assume "comp k k' = Gt"
hence 0: "lt k' k" by (simp only: Gt_lt_conv)
show "oalist_inv_raw (let va = f k' 0 v'; aux = map2_val_pair f g h ((k, v) # xs) ys
in if va = 0 then aux else (k', va) # aux)"
proof (simp add: Let_def, intro conjI impI)
assume "f k' 0 v' ≠ 0"
with Cons(5) show "oalist_inv_raw ((k', f k' 0 v') # map2_val_pair f g h ((k, v) # xs) ys)"
proof (rule oalist_inv_raw_ConsI)
define k0 where "k0 = fst (hd (map2_val_pair f g h ((k, v) # xs) ys))"
assume "map2_val_pair f g h ((k, v) # xs) ys ≠ []"
hence "k0 ∈ fst ` set (map2_val_pair f g h ((k, v) # xs) ys)" by (simp add: k0_def)
also from *(1) Cons(2) assms(3, 4) have "... ⊆ fst ` set ((k, v) # xs) ∪ fst ` set ys"
by (rule fst_map2_val_pair_subset)
finally have "k0 = k ∨ k0 ∈ fst ` set xs ∨ k0 ∈ fst ` set ys" by auto
thus "lt k' k0"
proof (elim disjE)
assume "k0 = k"
with 0 show ?thesis by simp
next
assume "k0 ∈ fst ` set xs"
hence "lt k k0" by (rule *(4))
with 0 show ?thesis by (rule less_trans)
qed (rule Cons(4))
qed
qed (rule Cons(5))
qed
qed
qed
lemma lookup_pair_map2_val_pair:
assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
assumes "map2_val_compat g" and "map2_val_compat h"
assumes "⋀zs. oalist_inv_raw zs ⟹ g zs = map_val_pair (λk v. f k v 0) zs"
and "⋀zs. oalist_inv_raw zs ⟹ h zs = map_val_pair (λk. f k 0) zs"
and "⋀k. f k 0 0 = 0"
shows "lookup_pair (map2_val_pair f g h xs ys) k0 = f k0 (lookup_pair xs k0) (lookup_pair ys k0)"
using assms(1, 2)
proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
case Nil
show ?case
proof (cases ys)
case Nil
show ?thesis by (simp add: Nil map2_val_compat_Nil[OF assms(3)] assms(7))
next
case (Cons y ys')
then obtain k v ys' where ys: "ys = (k, v) # ys'" by fastforce
from Nil have "lookup_pair (h ys) k0 = lookup_pair (map_val_pair (λk. f k 0) ys) k0"
by (simp only: assms(6))
also have "... = f k0 0 (lookup_pair ys k0)" by (rule lookup_pair_map_val_pair, fact Nil, fact assms(7))
finally have "lookup_pair (h ((k, v) # ys')) k0 = f k0 0 (lookup_pair ((k, v) # ys') k0)"
by (simp only: ys)
thus ?thesis by (simp add: ys)
qed
next
case *: (Cons k v xs)
from *(6) show ?case
proof (induct ys rule: oalist_inv_raw_induct)
case Nil
from *(1) have "lookup_pair (g ((k, v) # xs)) k0 = lookup_pair (map_val_pair (λk v. f k v 0) ((k, v) # xs)) k0"
by (simp only: assms(5))
also have "... = f k0 (lookup_pair ((k, v) # xs) k0) 0"
by (rule lookup_pair_map_val_pair, fact *(1), fact assms(7))
finally show ?case by simp
next
case (Cons k' v' ys)
show ?case
proof (cases "comp k0 k = Lt ∧ comp k0 k' = Lt")
case True
hence 1: "comp k0 k = Lt" and 2: "comp k0 k' = Lt" by simp_all
hence eq: "f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0) = 0"
by (simp add: assms(7))
from *(1) Cons(1) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h ((k, v) # xs) ((k', v') # ys))"
by (rule oalist_inv_raw_map2_val_pair)
show ?thesis
proof (simp only: eq lookup_pair_eq_0[OF inv], rule)
assume "k0 ∈ fst ` set (local.map2_val_pair f g h ((k, v) # xs) ((k', v') # ys))"
also from *(1) Cons(1) assms(3, 4) have "... ⊆ fst ` set ((k, v) # xs) ∪ fst ` set ((k', v') # ys)"
by (rule fst_map2_val_pair_subset)
finally have "k0 ∈ fst ` set xs ∨ k0 ∈ fst ` set ys" using 1 2 by auto
thus False
proof
assume "k0 ∈ fst ` set xs"
hence "lt k k0" by (rule *(4))
with 1 show ?thesis by (simp add: Lt_lt_conv)
next
assume "k0 ∈ fst ` set ys"
hence "lt k' k0" by (rule Cons(4))
with 2 show ?thesis by (simp add: Lt_lt_conv)
qed
qed
next
case False
show ?thesis
proof (simp split: order.split del: lookup_pair.simps, intro conjI impI)
assume "comp k k' = Lt"
with False have "comp k0 k ≠ Lt" by (auto simp: Lt_lt_conv)
show "lookup_pair (let v = f k v 0; aux = map2_val_pair f g h xs ((k', v') # ys)
in if v = 0 then aux else (k, v) # aux) k0 =
f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
proof (cases "comp k0 k")
case Lt
with ‹comp k0 k ≠ Lt› show ?thesis ..
next
case Eq
hence "k0 = k" by (simp only: eq)
with ‹comp k k' = Lt› have "comp k0 k' = Lt" by simp
hence eq1: "lookup_pair ((k', v') # ys) k = 0" by (simp add: ‹k0 = k›)
have eq2: "lookup_pair ((k, v) # xs) k = v" by simp
show ?thesis
proof (simp add: Let_def eq1 eq2 ‹k0 = k› del: lookup_pair.simps, intro conjI impI)
from *(2) Cons(1) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h xs ((k', v') # ys))"
by (rule oalist_inv_raw_map2_val_pair)
show "lookup_pair (map2_val_pair f g h xs ((k', v') # ys)) k = 0"
proof (simp only: lookup_pair_eq_0[OF inv], rule)
assume "k ∈ fst ` set (local.map2_val_pair f g h xs ((k', v') # ys))"
also from *(2) Cons(1) assms(3, 4) have "... ⊆ fst ` set xs ∪ fst ` set ((k', v') # ys)"
by (rule fst_map2_val_pair_subset)
finally have "k ∈ fst ` set xs ∨ k ∈ fst ` set ys" using ‹comp k k' = Lt›
by auto
thus False
proof
assume "k ∈ fst ` set xs"
hence "lt k k" by (rule *(4))
thus ?thesis by simp
next
assume "k ∈ fst ` set ys"
hence "lt k' k" by (rule Cons(4))
with ‹comp k k' = Lt› show ?thesis by (simp add: Lt_lt_conv)
qed
qed
qed simp
next
case Gt
hence eq1: "lookup_pair ((k, v) # xs) k0 = lookup_pair xs k0"
and eq2: "lookup_pair ((k, f k v 0) # map2_val_pair f g h xs ((k', v') # ys)) k0 =
lookup_pair (map2_val_pair f g h xs ((k', v') # ys)) k0" by simp_all
show ?thesis
by (simp add: Let_def eq1 eq2 del: lookup_pair.simps, rule *(5), fact Cons(1))
qed
next
assume "comp k k' = Eq"
hence "k = k'" by (simp only: eq)
with False have "comp k0 k' ≠ Lt" by (auto simp: Lt_lt_conv)
show "lookup_pair (let v = f k v v'; aux = map2_val_pair f g h xs ys in
if v = 0 then aux else (k, v) # aux) k0 =
f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
proof (cases "comp k0 k'")
case Lt
with ‹comp k0 k' ≠ Lt› show ?thesis ..
next
case Eq
hence "k0 = k'" by (simp only: eq)
show ?thesis
proof (simp add: Let_def ‹k = k'› ‹k0 = k'›, intro impI)
from *(2) Cons(2) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h xs ys)"
by (rule oalist_inv_raw_map2_val_pair)
show "lookup_pair (map2_val_pair f g h xs ys) k' = 0"
proof (simp only: lookup_pair_eq_0[OF inv], rule)
assume "k' ∈ fst ` set (map2_val_pair f g h xs ys)"
also from *(2) Cons(2) assms(3, 4) have "... ⊆ fst ` set xs ∪ fst ` set ys"
by (rule fst_map2_val_pair_subset)
finally show False
proof
assume "k' ∈ fst ` set ys"
hence "lt k' k'" by (rule Cons(4))
thus ?thesis by simp
next
assume "k' ∈ fst ` set xs"
hence "lt k k'" by (rule *(4))
thus ?thesis by (simp add: ‹k = k'›)
qed
qed
qed
next
case Gt
hence eq1: "lookup_pair ((k, v) # xs) k0 = lookup_pair xs k0"
and eq2: "lookup_pair ((k', v') # ys) k0 = lookup_pair ys k0"
and eq3: "lookup_pair ((k, f k v v') # map2_val_pair f g h xs ys) k0 =
lookup_pair (map2_val_pair f g h xs ys) k0" by (simp_all add: ‹k = k'›)
show ?thesis by (simp add: Let_def eq1 eq2 eq3 del: lookup_pair.simps, rule *(5), fact Cons(2))
qed
next
assume "comp k k' = Gt"
hence "comp k' k = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
with False have "comp k0 k' ≠ Lt" by (auto simp: Lt_lt_conv)
show "lookup_pair (let va = f k' 0 v'; aux = map2_val_pair f g h ((k, v) # xs) ys
in if va = 0 then aux else (k', va) # aux) k0 =
f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
proof (cases "comp k0 k'")
case Lt
with ‹comp k0 k' ≠ Lt› show ?thesis ..
next
case Eq
hence "k0 = k'" by (simp only: eq)
with ‹comp k' k = Lt› have "comp k0 k = Lt" by simp
hence eq1: "lookup_pair ((k, v) # xs) k' = 0" by (simp add: ‹k0 = k'›)
have eq2: "lookup_pair ((k', v') # ys) k' = v'" by simp
show ?thesis
proof (simp add: Let_def eq1 eq2 ‹k0 = k'› del: lookup_pair.simps, intro conjI impI)
from *(1) Cons(2) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h ((k, v) # xs) ys)"
by (rule oalist_inv_raw_map2_val_pair)
show "lookup_pair (map2_val_pair f g h ((k, v) # xs) ys) k' = 0"
proof (simp only: lookup_pair_eq_0[OF inv], rule)
assume "k' ∈ fst ` set (map2_val_pair f g h ((k, v) # xs) ys)"
also from *(1) Cons(2) assms(3, 4) have "... ⊆ fst ` set ((k, v) # xs) ∪ fst ` set ys"
by (rule fst_map2_val_pair_subset)
finally have "k' ∈ fst ` set xs ∨ k' ∈ fst ` set ys" using ‹comp k' k = Lt›
by auto
thus False
proof
assume "k' ∈ fst ` set ys"
hence "lt k' k'" by (rule Cons(4))
thus ?thesis by simp
next
assume "k' ∈ fst ` set xs"
hence "lt k k'" by (rule *(4))
with ‹comp k' k = Lt› show ?thesis by (simp add: Lt_lt_conv)
qed
qed
qed simp
next
case Gt
hence eq1: "lookup_pair ((k', v') # ys) k0 = lookup_pair ys k0"
and eq2: "lookup_pair ((k', f k' 0 v') # map2_val_pair f g h ((k, v) # xs) ys) k0 =
lookup_pair (map2_val_pair f g h ((k, v) # xs) ys) k0" by simp_all
show ?thesis by (simp add: Let_def eq1 eq2 del: lookup_pair.simps, rule Cons(5))
qed
qed
qed
qed
qed
lemma map2_val_pair_singleton_eq_update_by_fun_pair:
assumes "oalist_inv_raw xs"
assumes "⋀k x. f k x 0 = x" and "⋀zs. oalist_inv_raw zs ⟹ g zs = zs"
and "h [(k, v)] = map_val_pair (λk. f k 0) [(k, v)]"
shows "map2_val_pair f g h xs [(k, v)] = update_by_fun_pair k (λx. f k x v) xs"
using assms(1)
proof (induct xs rule: oalist_inv_raw_induct)
case Nil
show ?case by (simp add: Let_def assms(4))
next
case (Cons k' v' xs)
show ?case
proof (cases "comp k' k")
case Lt
hence gr: "comp k k' = Gt" by (simp only: Gt_lt_conv Lt_lt_conv)
show ?thesis by (simp add: Lt gr Let_def assms(2) Cons(3, 5))
next
case Eq
hence eq1: "comp k k' = Eq" and eq2: "k = k'" by (simp_all only: eq)
show ?thesis by (simp add: Eq eq1 eq2 Let_def assms(3)[OF Cons(2)])
next
case Gt
hence less: "comp k k' = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
show ?thesis by (simp add: Gt less Let_def assms(3)[OF Cons(1)])
qed
qed
subsubsection ‹@{const lex_ord_pair}›
lemma lex_ord_pair_EqI:
assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
and "⋀k. k ∈ fst ` set xs ∪ fst ` set ys ⟹ f k (lookup_pair xs k) (lookup_pair ys k) = Some Eq"
shows "lex_ord_pair f xs ys = Some Eq"
using assms
proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
case Nil
thus ?case
proof (induct ys rule: oalist_inv_raw_induct)
case Nil
show ?case by simp
next
case (Cons k v ys)
show ?case
proof (simp add: Let_def, intro conjI impI, rule Cons(5))
fix k0
assume "k0 ∈ fst ` set [] ∪ fst ` set ys"
hence "k0 ∈ fst ` set ys" by simp
hence "lt k k0" by (rule Cons(4))
hence "f k0 (lookup_pair [] k0) (lookup_pair ys k0) = f k0 (lookup_pair [] k0) (lookup_pair ((k, v) # ys) k0)"
by (auto simp add: lookup_pair_Cons[OF Cons(1)] simp del: lookup_pair.simps)
also have "... = Some Eq" by (rule Cons(6), simp add: ‹k0 ∈ fst ` set ys›)
finally show "f k0 (lookup_pair [] k0) (lookup_pair ys k0) = Some Eq" .
next
have "f k 0 v = f k (lookup_pair [] k) (lookup_pair ((k, v) # ys) k)" by simp
also have "... = Some Eq" by (rule Cons(6), simp)
finally show "f k 0 v = Some Eq" .
qed
qed
next
case *: (Cons k v xs)
from *(6, 7) show ?case
proof (induct ys rule: oalist_inv_raw_induct)
case Nil
show ?case
proof (simp add: Let_def, intro conjI impI, rule *(5), rule oalist_inv_raw_Nil)
fix k0
assume "k0 ∈ fst ` set xs ∪ fst ` set []"
hence "k0 ∈ fst ` set xs" by simp
hence "lt k k0" by (rule *(4))
hence "f k0 (lookup_pair xs k0) (lookup_pair [] k0) = f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair [] k0)"
by (auto simp add: lookup_pair_Cons[OF *(1)] simp del: lookup_pair.simps)
also have "... = Some Eq" by (rule Nil, simp add: ‹k0 ∈ fst ` set xs›)
finally show "f k0 (lookup_pair xs k0) (lookup_pair [] k0) = Some Eq" .
next
have "f k v 0 = f k (lookup_pair ((k, v) # xs) k) (lookup_pair [] k)" by simp
also have "... = Some Eq" by (rule Nil, simp)
finally show "f k v 0 = Some Eq" .
qed
next
case (Cons k' v' ys)
show ?case
proof (simp split: order.split, intro conjI impI)
assume "comp k k' = Lt"
show "(let aux = f k v 0 in if aux = Some Eq then lex_ord_pair f xs ((k', v') # ys) else aux) = Some Eq"
proof (simp add: Let_def, intro conjI impI, rule *(5), rule Cons(1))
fix k0
assume k0_in: "k0 ∈ fst ` set xs ∪ fst ` set ((k', v') # ys)"
hence "k0 ∈ fst ` set xs ∨ k0 = k' ∨ k0 ∈ fst ` set ys" by auto
hence "k0 ≠ k"
proof (elim disjE)
assume "k0 ∈ fst ` set xs"
hence "lt k k0" by (rule *(4))
thus ?thesis by simp
next
assume "k0 = k'"
with ‹comp k k' = Lt› show ?thesis by auto
next
assume "k0 ∈ fst ` set ys"
hence "lt k' k0" by (rule Cons(4))
with ‹comp k k' = Lt› show ?thesis by (simp add: Lt_lt_conv)
qed
hence "f k0 (lookup_pair xs k0) (lookup_pair ((k', v') # ys) k0) =
f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
by (auto simp add: lookup_pair_Cons[OF *(1)] simp del: lookup_pair.simps)
also have "... = Some Eq" by (rule Cons(6), rule rev_subsetD, fact k0_in, auto)
finally show "f k0 (lookup_pair xs k0) (lookup_pair ((k', v') # ys) k0) = Some Eq" .
next
have "f k v 0 = f k (lookup_pair ((k, v) # xs) k) (lookup_pair ((k', v') # ys) k)"
by (simp add: ‹comp k k' = Lt›)
also have "... = Some Eq" by (rule Cons(6), simp)
finally show "f k v 0 = Some Eq" .
qed
next
assume "comp k k' = Eq"
hence "k = k'" by (simp only: eq)
show "(let aux = f k v v' in if aux = Some Eq then lex_ord_pair f xs ys else aux) = Some Eq"
proof (simp add: Let_def, intro conjI impI, rule *(5), rule Cons(2))
fix k0
assume k0_in: "k0 ∈ fst ` set xs ∪ fst ` set ys"
hence "k0 ≠ k'"
proof
assume "k0 ∈ fst ` set xs"
hence "lt k k0" by (rule *(4))
thus ?thesis by (simp add: ‹k = k'›)
next
assume "k0 ∈ fst ` set ys"
hence "lt k' k0" by (rule Cons(4))
thus ?thesis by simp
qed
hence "f k0 (lookup_pair xs k0) (lookup_pair ys k0) =
f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
by (simp add: lookup_pair_Cons[OF *(1)] lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps,
auto simp: ‹k = k'›)
also have "... = Some Eq" by (rule Cons(6), rule rev_subsetD, fact k0_in, auto)
finally show "f k0 (lookup_pair xs k0) (lookup_pair ys k0) = Some Eq" .
next
have "f k v v' = f k (lookup_pair ((k, v) # xs) k) (lookup_pair ((k', v') # ys) k)"
by (simp add: ‹k = k'›)
also have "... = Some Eq" by (rule Cons(6), simp)
finally show "f k v v' = Some Eq" .
qed
next
assume "comp k k' = Gt"
hence "comp k' k = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
show "(let aux = f k' 0 v' in if aux = Some Eq then lex_ord_pair f ((k, v) # xs) ys else aux) = Some Eq"
proof (simp add: Let_def, intro conjI impI, rule Cons(5))
fix k0
assume k0_in: "k0 ∈ fst ` set ((k, v) # xs) ∪ fst ` set ys"
hence "k0 ∈ fst ` set xs ∨ k0 = k ∨ k0 ∈ fst ` set ys" by auto
hence "k0 ≠ k'"
proof (elim disjE)
assume "k0 ∈ fst ` set xs"
hence "lt k k0" by (rule *(4))
with ‹comp k' k = Lt› show ?thesis by (simp add: Lt_lt_conv)
next
assume "k0 = k"
with ‹comp k' k = Lt› show ?thesis by auto
next
assume "k0 ∈ fst ` set ys"
hence "lt k' k0" by (rule Cons(4))
thus ?thesis by simp
qed
hence "f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ys k0) =
f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
by (auto simp add: lookup_pair_Cons[OF Cons(1)] simp del: lookup_pair.simps)
also have "... = Some Eq" by (rule Cons(6), rule rev_subsetD, fact k0_in, auto)
finally show "f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ys k0) = Some Eq" .
next
have "f k' 0 v' = f k' (lookup_pair ((k, v) # xs) k') (lookup_pair ((k', v') # ys) k')"
by (simp add: ‹comp k' k = Lt›)
also have "... = Some Eq" by (rule Cons(6), simp)
finally show "f k' 0 v' = Some Eq" .
qed
qed
qed
qed
lemma lex_ord_pair_valI:
assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "aux ≠ Some Eq"
assumes "k ∈ fst ` set xs ∪ fst ` set ys" and "aux = f k (lookup_pair xs k) (lookup_pair ys k)"
and "⋀k'. k' ∈ fst ` set xs ∪ fst ` set ys ⟹ lt k' k ⟹
f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq"
shows "lex_ord_pair f xs ys = aux"
using assms(1, 2, 4, 5, 6)
proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
case Nil
thus ?case
proof (induct ys rule: oalist_inv_raw_induct)
case Nil
from Nil(1) show ?case by simp
next
case (Cons k' v' ys)
from Cons(6) have "k = k' ∨ k ∈ fst ` set ys" by simp
thus ?case
proof
assume "k = k'"
with Cons(7) have "f k' 0 v' = aux" by simp
thus ?thesis by (simp add: Let_def ‹k = k'› assms(3))
next
assume "k ∈ fst `set ys"
hence "lt k' k" by (rule Cons(4))
hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
hence eq1: "lookup_pair ((k', v') # ys) k = lookup_pair ys k" by simp
have "f k' (lookup_pair [] k') (lookup_pair ((k', v') # ys) k') = Some Eq"
by (rule Cons(8), simp, fact)
hence eq2: "f k' 0 v' = Some Eq" by simp
show ?thesis
proof (simp add: Let_def eq2, rule Cons(5))
from ‹k ∈ fst `set ys› show "k ∈ fst ` set [] ∪ fst ` set ys" by simp
next
show "aux = f k (lookup_pair [] k) (lookup_pair ys k)" by (simp only: Cons(7) eq1)
next
fix k0
assume "lt k0 k"
assume "k0 ∈ fst ` set [] ∪ fst ` set ys"
hence k0_in: "k0 ∈ fst ` set ys" by simp
hence "lt k' k0" by (rule Cons(4))
hence "comp k0 k' = Gt" by (simp add: Gt_lt_conv)
hence "f k0 (lookup_pair [] k0) (lookup_pair ys k0) =
f k0 (lookup_pair [] k0) (lookup_pair ((k', v') # ys) k0)" by simp
also have "... = Some Eq" by (rule Cons(8), simp add: k0_in, fact)
finally show "f k0 (lookup_pair [] k0) (lookup_pair ys k0) = Some Eq" .
qed
qed
qed
next
case *: (Cons k' v' xs)
from *(6, 7, 8, 9) show ?case
proof (induct ys rule: oalist_inv_raw_induct)
case Nil
from Nil(1) have "k = k' ∨ k ∈ fst ` set xs" by simp
thus ?case
proof
assume "k = k'"
with Nil(2) have "f k' v' 0 = aux" by simp
thus ?thesis by (simp add: Let_def ‹k = k'› assms(3))
next
assume "k ∈ fst ` set xs"
hence "lt k' k" by (rule *(4))
hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
hence eq1: "lookup_pair ((k', v') # xs) k = lookup_pair xs k" by simp
have "f k' (lookup_pair ((k', v') # xs) k') (lookup_pair [] k') = Some Eq"
by (rule Nil(3), simp, fact)
hence eq2: "f k' v' 0 = Some Eq" by simp
show ?thesis
proof (simp add: Let_def eq2, rule *(5), fact oalist_inv_raw_Nil)
from ‹k ∈ fst `set xs› show "k ∈ fst ` set xs ∪ fst ` set []" by simp
next
show "aux = f k (lookup_pair xs k) (lookup_pair [] k)" by (simp only: Nil(2) eq1)
next
fix k0
assume "lt k0 k"
assume "k0 ∈ fst ` set xs ∪ fst ` set []"
hence k0_in: "k0 ∈ fst ` set xs" by simp
hence "lt k' k0" by (rule *(4))
hence "comp k0 k' = Gt" by (simp add: Gt_lt_conv)
hence "f k0 (lookup_pair xs k0) (lookup_pair [] k0) =
f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair [] k0)" by simp
also have "... = Some Eq" by (rule Nil(3), simp add: k0_in, fact)
finally show "f k0 (lookup_pair xs k0) (lookup_pair [] k0) = Some Eq" .
qed
qed
next
case (Cons k'' v'' ys)
have 0: thesis if 1: "lt k k'" and 2: "lt k k''" for thesis
proof -
from 1 have "k ≠ k'" by simp
moreover from 2 have "k ≠ k''" by simp
ultimately have "k ∈ fst ` set xs ∨ k ∈ fst ` set ys" using Cons(6) by simp
thus ?thesis
proof
assume "k ∈ fst ` set xs"
hence "lt k' k" by (rule *(4))
with 1 show ?thesis by simp
next
assume "k ∈ fst ` set ys"
hence "lt k'' k" by (rule Cons(4))
with 2 show ?thesis by simp
qed
qed
show ?case
proof (simp split: order.split, intro conjI impI)
assume Lt: "comp k' k'' = Lt"
show "(let aux = f k' v' 0 in if aux = Some Eq then lex_ord_pair f xs ((k'', v'') # ys) else aux) = aux"
proof (simp add: Let_def split: order.split, intro conjI impI)
assume "f k' v' 0 = Some Eq"
have "k ≠ k'"
proof
assume "k = k'"
have "aux = f k v' 0" by (simp add: Cons(7) ‹k = k'› Lt)
with ‹f k' v' 0 = Some Eq› assms(3) show False by (simp add: ‹k = k'›)
qed
from Cons(1) show "lex_ord_pair f xs ((k'', v'') # ys) = aux"
proof (rule *(5))
from Cons(6) ‹k ≠ k'› show "k ∈ fst ` set xs ∪ fst ` set ((k'', v'') # ys)" by simp
next
show "aux = f k (lookup_pair xs k) (lookup_pair ((k'', v'') # ys) k)"
by (simp add: Cons(7) lookup_pair_Cons[OF *(1)] ‹k ≠ k'›[symmetric] del: lookup_pair.simps)
next
fix k0
assume "lt k0 k"
assume k0_in: "k0 ∈ fst ` set xs ∪ fst ` set ((k'', v'') # ys)"
also have "... ⊆ fst ` set ((k', v') # xs) ∪ fst ` set ((k'', v'') # ys)" by fastforce
finally have k0_in': "k0 ∈ fst ` set ((k', v') # xs) ∪ fst ` set ((k'', v'') # ys)" .
have "k' ≠ k0"
proof
assume "k' = k0"
with k0_in have "k' ∈ fst ` set xs ∪ fst ` set ((k'', v'') # ys)" by simp
with Lt have "k' ∈ fst ` set xs ∨ k' ∈ fst ` set ys" by auto
thus False
proof
assume "k' ∈ fst ` set xs"
hence "lt k' k'" by (rule *(4))
thus ?thesis by simp
next
assume "k' ∈ fst ` set ys"
hence "lt k'' k'" by (rule Cons(4))
with Lt show ?thesis by (simp add: Lt_lt_conv)
qed
qed
hence "f k0 (lookup_pair xs k0) (lookup_pair ((k'', v'') # ys) k0) =
f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ((k'', v'') # ys) k0)"
by (simp add: lookup_pair_Cons[OF *(1)] del: lookup_pair.simps)
also from k0_in' ‹lt k0 k› have "... = Some Eq" by (rule Cons(8))
finally show "f k0 (lookup_pair xs k0) (lookup_pair ((k'', v'') # ys) k0) = Some Eq" .
qed
next
assume "f k' v' 0 ≠ Some Eq"
have "¬ lt k' k"
proof
have "k' ∈ fst ` set ((k', v') # xs) ∪ fst ` set ((k'', v'') # ys)" by simp
moreover assume "lt k' k"
ultimately have "f k' (lookup_pair ((k', v') # xs) k') (lookup_pair ((k'', v'') # ys) k') = Some Eq"
by (rule Cons(8))
hence "f k' v' 0 = Some Eq" by (simp add: Lt)
with ‹f k' v' 0 ≠ Some Eq› show False ..
qed
moreover have "¬ lt k k'"
proof
assume "lt k k'"
moreover from this Lt have "lt k k''" by (simp add: Lt_lt_conv)
ultimately show False by (rule 0)
qed
ultimately have "k = k'" by simp
show "f k' v' 0 = aux" by (simp add: Cons(7) ‹k = k'› Lt)
qed
next
assume "comp k' k'' = Eq"
hence "k' = k''" by (simp only: eq)
show "(let aux = f k' v' v'' in if aux = Some Eq then lex_ord_pair f xs ys else aux) = aux"
proof (simp add: Let_def ‹k' = k''› split: order.split, intro conjI impI)
assume "f k'' v' v'' = Some Eq"
have "k ≠ k''"
proof
assume "k = k''"
have "aux = f k v' v''" by (simp add: Cons(7) ‹k = k''› ‹k' = k''›)
with ‹f k'' v' v'' = Some Eq› assms(3) show False by (simp add: ‹k = k''›)
qed
from Cons(2) show "lex_ord_pair f xs ys = aux"
proof (rule *(5))
from Cons(6) ‹k ≠ k''› show "k ∈ fst ` set xs ∪ fst ` set ys" by (simp add: ‹k' = k''›)
next
show "aux = f k (lookup_pair xs k) (lookup_pair ys k)"
by (simp add: Cons(7) lookup_pair_Cons[OF *(1)] lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps,
simp add: ‹k' = k''› ‹k ≠ k''›[symmetric])
next
fix k0
assume "lt k0 k"
assume k0_in: "k0 ∈ fst ` set xs ∪ fst ` set ys"
also have "... ⊆ fst ` set ((k', v') # xs) ∪ fst ` set ((k'', v'') # ys)" by fastforce
finally have k0_in': "k0 ∈ fst ` set ((k', v') # xs) ∪ fst ` set ((k'', v'') # ys)" .
have "k'' ≠ k0"
proof
assume "k'' = k0"
with k0_in have "k'' ∈ fst ` set xs ∪ fst ` set ys" by simp
thus False
proof
assume "k'' ∈ fst ` set xs"
hence "lt k' k''" by (rule *(4))
thus ?thesis by (simp add: ‹k' = k''›)
next
assume "k'' ∈ fst ` set ys"
hence "lt k'' k''" by (rule Cons(4))
thus ?thesis by simp
qed
qed
hence "f k0 (lookup_pair xs k0) (lookup_pair ys k0) =
f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ((k'', v'') # ys) k0)"
by (simp add: lookup_pair_Cons[OF *(1)] lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps,
simp add: ‹k' = k''›)
also from k0_in' ‹lt k0 k› have "... = Some Eq" by (rule Cons(8))
finally show "f k0 (lookup_pair xs k0) (lookup_pair ys k0) = Some Eq" .
qed
next
assume "f k'' v' v'' ≠ Some Eq"
have "¬ lt k'' k"
proof
have "k'' ∈ fst ` set ((k', v') # xs) ∪ fst ` set ((k'', v'') # ys)" by simp
moreover assume "lt k'' k"
ultimately have "f k'' (lookup_pair ((k', v') # xs) k'') (lookup_pair ((k'', v'') # ys) k'') = Some Eq"
by (rule Cons(8))
hence "f k'' v' v'' = Some Eq" by (simp add: ‹k' = k''›)
with ‹f k'' v' v'' ≠ Some Eq› show False ..
qed
moreover have "¬ lt k k''"
proof
assume "lt k k''"
hence "lt k k'" by (simp only: ‹k' = k''›)
thus False using ‹lt k k''› by (rule 0)
qed
ultimately have "k = k''" by simp
show "f k'' v' v'' = aux" by (simp add: Cons(7) ‹k = k''› ‹k' = k''›)
qed
next
assume Gt: "comp k' k'' = Gt"
hence Lt: "comp k'' k' = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
show "(let aux = f k'' 0 v'' in if aux = Some Eq then lex_ord_pair f ((k', v') # xs) ys else aux) = aux"
proof (simp add: Let_def split: order.split, intro conjI impI)
assume "f k'' 0 v'' = Some Eq"
have "k ≠ k''"
proof
assume "k = k''"
have "aux = f k 0 v''" by (simp add: Cons(7) ‹k = k''› Lt)
with ‹f k'' 0 v'' = Some Eq› assms(3) show False by (simp add: ‹k = k''›)
qed
show "lex_ord_pair f ((k', v') # xs) ys = aux"
proof (rule Cons(5))
from Cons(6) ‹k ≠ k''› show "k ∈ fst ` set ((k', v') # xs) ∪ fst ` set ys" by simp
next
show "aux = f k (lookup_pair ((k', v') # xs) k) (lookup_pair ys k)"
by (simp add: Cons(7) lookup_pair_Cons[OF Cons(1)] ‹k ≠ k''›[symmetric] del: lookup_pair.simps)
next
fix k0
assume "lt k0 k"
assume k0_in: "k0 ∈ fst ` set ((k', v') # xs) ∪ fst ` set ys"
also have "... ⊆ fst ` set ((k', v') # xs) ∪ fst ` set ((k'', v'') # ys)" by fastforce
finally have k0_in': "k0 ∈ fst ` set ((k', v') # xs) ∪ fst ` set ((k'', v'') # ys)" .
have "k'' ≠ k0"
proof
assume "k'' = k0"
with k0_in have "k'' ∈ fst ` set ((k', v') # xs) ∪ fst ` set ys" by simp
with Lt have "k'' ∈ fst ` set xs ∨ k'' ∈ fst ` set ys" by auto
thus False
proof
assume "k'' ∈ fst ` set xs"
hence "lt k' k''" by (rule *(4))
with Lt show ?thesis by (simp add: Lt_lt_conv)
next
assume "k'' ∈ fst ` set ys"
hence "lt k'' k''" by (rule Cons(4))
thus ?thesis by simp
qed
qed
hence "f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ys k0) =
f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ((k'', v'') # ys) k0)"
by (simp add: lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps)
also from k0_in' ‹lt k0 k› have "... = Some Eq" by (rule Cons(8))
finally show "f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ys k0) = Some Eq" .
qed
next
assume "f k'' 0 v'' ≠ Some Eq"
have "¬ lt k'' k"
proof
have "k'' ∈ fst ` set ((k', v') # xs) ∪ fst ` set ((k'', v'') # ys)" by simp
moreover assume "lt k'' k"
ultimately have "f k'' (lookup_pair ((k', v') # xs) k'') (lookup_pair ((k'', v'') # ys) k'') = Some Eq"
by (rule Cons(8))
hence "f k'' 0 v'' = Some Eq" by (simp add: Lt)
with ‹f k'' 0 v'' ≠ Some Eq› show False ..
qed
moreover have "¬ lt k k''"
proof
assume "lt k k''"
with Lt have "lt k k'" by (simp add: Lt_lt_conv)
thus False using ‹lt k k''› by (rule 0)
qed
ultimately have "k = k''" by simp
show "f k'' 0 v'' = aux" by (simp add: Cons(7) ‹k = k''› Lt)
qed
qed
qed
qed
lemma lex_ord_pair_EqD:
assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "lex_ord_pair f xs ys = Some Eq"
and "k ∈ fst ` set xs ∪ fst ` set ys"
shows "f k (lookup_pair xs k) (lookup_pair ys k) = Some Eq"
proof (rule ccontr)
let ?A = "(fst ` set xs ∪ fst ` set ys) ∩ {k. f k (lookup_pair xs k) (lookup_pair ys k) ≠ Some Eq}"
define k0 where "k0 = Min ?A"
have "finite ?A" by auto
assume "f k (lookup_pair xs k) (lookup_pair ys k) ≠ Some Eq"
with assms(4) have "k ∈ ?A" by simp
hence "?A ≠ {}" by blast
with ‹finite ?A› have "k0 ∈ ?A" unfolding k0_def by (rule Min_in)
hence k0_in: "k0 ∈ fst ` set xs ∪ fst ` set ys"
and neq: "f k0 (lookup_pair xs k0) (lookup_pair ys k0) ≠ Some Eq" by simp_all
have "le k0 k'" if "k' ∈ ?A" for k' unfolding k0_def using ‹finite ?A› that
by (rule Min_le)
hence "f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq"
if "k' ∈ fst ` set xs ∪ fst ` set ys" and "lt k' k0" for k' using that by fastforce
with assms(1, 2) neq k0_in refl have "lex_ord_pair f xs ys = f k0 (lookup_pair xs k0) (lookup_pair ys k0)"
by (rule lex_ord_pair_valI)
with assms(3) neq show False by simp
qed
lemma lex_ord_pair_valE:
assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "lex_ord_pair f xs ys = aux"
and "aux ≠ Some Eq"
obtains k where "k ∈ fst ` set xs ∪ fst ` set ys" and "aux = f k (lookup_pair xs k) (lookup_pair ys k)"
and "⋀k'. k' ∈ fst ` set xs ∪ fst ` set ys ⟹ lt k' k ⟹
f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq"
proof -
let ?A = "(fst ` set xs ∪ fst ` set ys) ∩ {k. f k (lookup_pair xs k) (lookup_pair ys k) ≠ Some Eq}"
define k where "k = Min ?A"
have "finite ?A" by auto
have "∃k ∈ fst ` set xs ∪ fst ` set ys. f k (lookup_pair xs k) (lookup_pair ys k) ≠ Some Eq" (is ?prop)
proof (rule ccontr)
assume "¬ ?prop"
hence "f k (lookup_pair xs k) (lookup_pair ys k) = Some Eq"
if "k ∈ fst ` set xs ∪ fst ` set ys" for k using that by auto
with assms(1, 2) have "lex_ord_pair f xs ys = Some Eq" by (rule lex_ord_pair_EqI)
with assms(3, 4) show False by simp
qed
then obtain k0 where "k0 ∈ fst ` set xs ∪ fst ` set ys"
and "f k0 (lookup_pair xs k0) (lookup_pair ys k0) ≠ Some Eq" ..
hence "k0 ∈ ?A" by simp
hence "?A ≠ {}" by blast
with ‹finite ?A› have "k ∈ ?A" unfolding k_def by (rule Min_in)
hence k_in: "k ∈ fst ` set xs ∪ fst ` set ys"
and neq: "f k (lookup_pair xs k) (lookup_pair ys k) ≠ Some Eq" by simp_all
have "le k k'" if "k' ∈ ?A" for k' unfolding k_def using ‹finite ?A› that
by (rule Min_le)
hence *: "⋀k'. k' ∈ fst ` set xs ∪ fst ` set ys ⟹ lt k' k ⟹
f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq" by fastforce
with assms(1, 2) neq k_in refl have "lex_ord_pair f xs ys = f k (lookup_pair xs k) (lookup_pair ys k)"
by (rule lex_ord_pair_valI)
hence "aux = f k (lookup_pair xs k) (lookup_pair ys k)" by (simp only: assms(3))
with k_in show ?thesis using * ..
qed
subsubsection ‹@{const prod_ord_pair}›
lemma prod_ord_pair_eq_lex_ord_pair:
"prod_ord_pair P xs ys = (lex_ord_pair (λk x y. if P k x y then Some Eq else None) xs ys = Some Eq)"
proof (induct P xs ys rule: prod_ord_pair.induct)
case (1 P)
show ?case by simp
next
case (2 P ky vy ys)
thus ?case by simp
next
case (3 P kx vx xs)
thus ?case by simp
next
case (4 P kx vx xs ky vy ys)
show ?case
proof (cases "comp kx ky")
case Lt
thus ?thesis by (simp add: 4(2)[OF Lt])
next
case Eq
thus ?thesis by (simp add: 4(1)[OF Eq])
next
case Gt
thus ?thesis by (simp add: 4(3)[OF Gt])
qed
qed
lemma prod_ord_pairI:
assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
and "⋀k. k ∈ fst ` set xs ∪ fst ` set ys ⟹ P k (lookup_pair xs k) (lookup_pair ys k)"
shows "prod_ord_pair P xs ys"
unfolding prod_ord_pair_eq_lex_ord_pair by (rule lex_ord_pair_EqI, fact, fact, simp add: assms(3))
lemma prod_ord_pairD:
assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "prod_ord_pair P xs ys"
and "k ∈ fst ` set xs ∪ fst ` set ys"
shows "P k (lookup_pair xs k) (lookup_pair ys k)"
proof -
from assms have "(if P k (lookup_pair xs k) (lookup_pair ys k) then Some Eq else None) = Some Eq"
unfolding prod_ord_pair_eq_lex_ord_pair by (rule lex_ord_pair_EqD)
thus ?thesis by (simp split: if_splits)
qed
corollary prod_ord_pair_alt:
assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
shows "(prod_ord_pair P xs ys) ⟷ (∀k∈fst ` set xs ∪ fst ` set ys. P k (lookup_pair xs k) (lookup_pair ys k))"
using prod_ord_pairI[OF assms] prod_ord_pairD[OF assms] by meson
subsubsection ‹@{const sort_oalist}›
lemma oalist_inv_raw_foldr_update_by_pair:
assumes "oalist_inv_raw ys"
shows "oalist_inv_raw (foldr update_by_pair xs ys)"
proof (induct xs)
case Nil
from assms show ?case by simp
next
case (Cons x xs)
hence "oalist_inv_raw (update_by_pair x (foldr update_by_pair xs ys))"
by (rule oalist_inv_raw_update_by_pair)
thus ?case by simp
qed
corollary oalist_inv_raw_sort_oalist: "oalist_inv_raw (sort_oalist xs)"
proof -
from oalist_inv_raw_Nil have "oalist_inv_raw (foldr local.update_by_pair xs [])"
by (rule oalist_inv_raw_foldr_update_by_pair)
thus "oalist_inv_raw (sort_oalist xs)" by (simp only: sort_oalist_def)
qed
lemma sort_oalist_id:
assumes "oalist_inv_raw xs"
shows "sort_oalist xs = xs"
proof -
have "foldr update_by_pair xs ys = xs @ ys" if "oalist_inv_raw (xs @ ys)" for ys using assms that
proof (induct xs rule: oalist_inv_raw_induct)
case Nil
show ?case by simp
next
case (Cons k v xs)
from Cons(6) have *: "oalist_inv_raw ((k, v) # (xs @ ys))" by simp
hence 1: "oalist_inv_raw (xs @ ys)" by (rule oalist_inv_raw_ConsD1)
hence 2: "foldr update_by_pair xs ys = xs @ ys" by (rule Cons(5))
show ?case
proof (simp add: 2, rule update_by_pair_less)
from * show "v ≠ 0" by (auto simp: oalist_inv_raw_def)
next
have "comp k (fst (hd (xs @ ys))) = Lt ∨ xs @ ys = []"
proof (rule disjCI)
assume "xs @ ys ≠ []"
then obtain k'' v'' zs where eq0: "xs @ ys = (k'', v'') # zs"
using list.exhaust prod.exhaust by metis
from * have "lt k k''" by (simp add: eq0 oalist_inv_raw_def)
thus "comp k (fst (hd (xs @ ys))) = Lt" by (simp add: eq0 Lt_lt_conv)
qed
thus "xs @ ys = [] ∨ comp k (fst (hd (xs @ ys))) = Lt" by auto
qed
qed
with assms show ?thesis by (simp add: sort_oalist_def)
qed
lemma set_sort_oalist:
assumes "distinct (map fst xs)"
shows "set (sort_oalist xs) = {kv. kv ∈ set xs ∧ snd kv ≠ 0}"
using assms
proof (induct xs)
case Nil
show ?case by (simp add: sort_oalist_def)
next
case (Cons x xs)
obtain k v where x: "x = (k, v)" by fastforce
from Cons(2) have "distinct (map fst xs)" and "k ∉ fst ` set xs" by (simp_all add: x)
from this(1) have "set (sort_oalist xs) = {kv ∈ set xs. snd kv ≠ 0}" by (rule Cons(1))
with ‹k ∉ fst ` set xs› have eq: "set (sort_oalist xs) - range (Pair k) = {kv ∈ set xs. snd kv ≠ 0}"
by (auto simp: image_iff)
have "set (sort_oalist (x # xs)) = set (update_by_pair (k, v) (sort_oalist xs))"
by (simp add: sort_oalist_def x)
also have "... = {kv ∈ set (x # xs). snd kv ≠ 0}"
proof (cases "v = 0")
case True
have "set (update_by_pair (k, v) (sort_oalist xs)) = set (sort_oalist xs) - range (Pair k)"
unfolding True using oalist_inv_raw_sort_oalist by (rule set_update_by_pair_zero)
also have "... = {kv ∈ set (x # xs). snd kv ≠ 0}" by (auto simp: eq x True)
finally show ?thesis .
next
case False
with oalist_inv_raw_sort_oalist
have "set (update_by_pair (k, v) (sort_oalist xs)) = insert (k, v) (set (sort_oalist xs) - range (Pair k))"
by (rule set_update_by_pair)
also have "... = {kv ∈ set (x # xs). snd kv ≠ 0}" by (auto simp: eq x False)
finally show ?thesis .
qed
finally show ?case .
qed
lemma lookup_pair_sort_oalist':
assumes "distinct (map fst xs)"
shows "lookup_pair (sort_oalist xs) = lookup_dflt xs"
using assms
proof (induct xs)
case Nil
show ?case by (simp add: sort_oalist_def lookup_dflt_def)
next
case (Cons x xs)
obtain k v where x: "x = (k, v)" by fastforce
from Cons(2) have "distinct (map fst xs)" and "k ∉ fst ` set xs" by (simp_all add: x)
from this(1) have eq1: "lookup_pair (sort_oalist xs) = lookup_dflt xs" by (rule Cons(1))
have eq2: "sort_oalist (x # xs) = update_by_pair (k, v) (sort_oalist xs)" by (simp add: x sort_oalist_def)
show ?case
proof
fix k'
have "lookup_pair (sort_oalist (x # xs)) k' = (if k = k' then v else lookup_dflt xs k')"
by (simp add: eq1 eq2 lookup_pair_update_by_pair[OF oalist_inv_raw_sort_oalist])
also have "... = lookup_dflt (x # xs) k'" by (simp add: x lookup_dflt_def)
finally show "lookup_pair (sort_oalist (x # xs)) k' = lookup_dflt (x # xs) k'" .
qed
qed
end
locale comparator2 = comparator comp1 + cmp2: comparator comp2 for comp1 comp2 :: "'a comparator"
begin
lemma set_sort_oalist:
assumes "cmp2.oalist_inv_raw xs"
shows "set (sort_oalist xs) = set xs"
proof -
have rl: "set (foldr update_by_pair xs ys) = set xs ∪ set ys"
if "oalist_inv_raw ys" and "fst ` set xs ∩ fst ` set ys = {}" for ys
using assms that(2)
proof (induct xs rule: cmp2.oalist_inv_raw_induct)
case Nil
show ?case by simp
next
case (Cons k v xs)
from Cons(6) have "k ∉ fst ` set ys" and "fst ` set xs ∩ fst ` set ys = {}" by simp_all
from this(2) have eq1: "set (foldr update_by_pair xs ys) = set xs ∪ set ys" by (rule Cons(5))
have "¬ cmp2.lt k k" by auto
with Cons(4) have "k ∉ fst ` set xs" by blast
with ‹k ∉ fst ` set ys› have "k ∉ fst ` (set xs ∪ set ys)" by (simp add: image_Un)
hence "(set xs ∪ set ys) ∩ range (Pair k) = {}" by (smt Int_emptyI fstI image_iff)
hence eq2: "(set xs ∪ set ys) - range (Pair k) = set xs ∪ set ys" by (rule Diff_triv)
from ‹oalist_inv_raw ys› have "oalist_inv_raw (foldr update_by_pair xs ys)"
by (rule oalist_inv_raw_foldr_update_by_pair)
hence "set (update_by_pair (k, v) (foldr update_by_pair xs ys)) =
insert (k, v) (set (foldr update_by_pair xs ys) - range (Pair k))"
using Cons(3) by (rule set_update_by_pair)
also have "... = insert (k, v) (set xs ∪ set ys)" by (simp only: eq1 eq2)
finally show ?case by simp
qed
have "set (foldr update_by_pair xs []) = set xs ∪ set []"
by (rule rl, fact oalist_inv_raw_Nil, simp)
thus ?thesis by (simp add: sort_oalist_def)
qed
lemma lookup_pair_eqI:
assumes "oalist_inv_raw xs" and "cmp2.oalist_inv_raw ys" and "set xs = set ys"
shows "lookup_pair xs = cmp2.lookup_pair ys"
proof
fix k
show "lookup_pair xs k = cmp2.lookup_pair ys k"
proof (cases "cmp2.lookup_pair ys k = 0")
case True
with assms(2) have "k ∉ fst ` set ys" by (simp add: cmp2.lookup_pair_eq_0)
with assms(1) show ?thesis by (simp add: True assms(3)[symmetric] lookup_pair_eq_0)
next
case False
define v where "v = cmp2.lookup_pair ys k"
from False have "v ≠ 0" by (simp add: v_def)
with assms(2) v_def[symmetric] have "(k, v) ∈ set ys" by (simp add: cmp2.lookup_pair_eq_value)
with assms(1) ‹v ≠ 0› have "lookup_pair xs k = v"
by (simp add: assms(3)[symmetric] lookup_pair_eq_value)
thus ?thesis by (simp only: v_def)
qed
qed
corollary lookup_pair_sort_oalist:
assumes "cmp2.oalist_inv_raw xs"
shows "lookup_pair (sort_oalist xs) = cmp2.lookup_pair xs"
by (rule lookup_pair_eqI, rule oalist_inv_raw_sort_oalist, fact, rule set_sort_oalist, fact)
end
subsection ‹Invariant on Pairs›
type_synonym ('a, 'b, 'c) oalist_raw = "('a × 'b) list × 'c"
locale oalist_raw = fixes rep_key_order::"'o ⇒ 'a key_order"
begin
sublocale comparator "key_compare (rep_key_order x)"
by (fact comparator_key_compare)
definition oalist_inv :: "('a, 'b::zero, 'o) oalist_raw ⇒ bool"
where "oalist_inv xs ⟷ oalist_inv_raw (snd xs) (fst xs)"
lemma oalist_inv_alt: "oalist_inv (xs, ko) ⟷ oalist_inv_raw ko xs"
by (simp add: oalist_inv_def)
subsection ‹Operations on Raw Ordered Associative Lists›
fun sort_oalist_aux :: "'o ⇒ ('a, 'b, 'o) oalist_raw ⇒ ('a × 'b::zero) list"
where "sort_oalist_aux ko (xs, ox) = (if ko = ox then xs else sort_oalist ko xs)"
fun lookup_raw :: "('a, 'b, 'o) oalist_raw ⇒ 'a ⇒ 'b::zero"
where "lookup_raw (xs, ko) = lookup_pair ko xs"
definition sorted_domain_raw :: "'o ⇒ ('a, 'b::zero, 'o) oalist_raw ⇒ 'a list"
where "sorted_domain_raw ko xs = map fst (sort_oalist_aux ko xs)"
fun tl_raw :: "('a, 'b, 'o) oalist_raw ⇒ ('a, 'b::zero, 'o) oalist_raw"
where "tl_raw (xs, ko) = (List.tl xs, ko)"
fun min_key_val_raw :: "'o ⇒ ('a, 'b, 'o) oalist_raw ⇒ ('a × 'b::zero)"
where "min_key_val_raw ko (xs, ox) =
(if ko = ox then List.hd else min_list_param (λx y. le ko (fst x) (fst y))) xs"
fun update_by_raw :: "('a × 'b) ⇒ ('a, 'b, 'o) oalist_raw ⇒ ('a, 'b::zero, 'o) oalist_raw"
where "update_by_raw kv (xs, ko) = (update_by_pair ko kv xs, ko)"
fun update_by_fun_raw :: "'a ⇒ ('b ⇒ 'b) ⇒ ('a, 'b, 'o) oalist_raw ⇒ ('a, 'b::zero, 'o) oalist_raw"
where "update_by_fun_raw k f (xs, ko) = (update_by_fun_pair ko k f xs, ko)"
fun update_by_fun_gr_raw :: "'a ⇒ ('b ⇒ 'b) ⇒ ('a, 'b, 'o) oalist_raw ⇒ ('a, 'b::zero, 'o) oalist_raw"
where "update_by_fun_gr_raw k f (xs, ko) = (update_by_fun_gr_pair ko k f xs, ko)"
fun (in -) filter_raw :: "('a ⇒ bool) ⇒ ('a list × 'b) ⇒ ('a list × 'b)"
where "filter_raw P (xs, ko) = (filter P xs, ko)"
fun (in -) map_raw :: "(('a × 'b) ⇒ ('a × 'c)) ⇒ (('a × 'b::zero) list × 'd) ⇒ ('a × 'c::zero) list × 'd"
where "map_raw f (xs, ko) = (map_pair f xs, ko)"
abbreviation (in -) "map_val_raw f ≡ map_raw (λ(k, v). (k, f k v))"
fun map2_val_raw :: "('a ⇒ 'b ⇒ 'c ⇒ 'd) ⇒ (('a, 'b, 'o) oalist_raw ⇒ ('a, 'd, 'o) oalist_raw) ⇒
(('a, 'c, 'o) oalist_raw ⇒ ('a, 'd, 'o) oalist_raw) ⇒
('a, 'b::zero, 'o) oalist_raw ⇒ ('a, 'c::zero, 'o) oalist_raw ⇒
('a, 'd::zero, 'o) oalist_raw"
where "map2_val_raw f g h (xs, ox) ys =
(map2_val_pair ox f (λzs. fst (g (zs, ox))) (λzs. fst (h (zs, ox)))
xs (sort_oalist_aux ox ys), ox)"
definition lex_ord_raw :: "'o ⇒ ('a ⇒ (('b, 'c) comp_opt)) ⇒
(('a, 'b::zero, 'o) oalist_raw, ('a, 'c::zero, 'o) oalist_raw) comp_opt"
where "lex_ord_raw ko f xs ys = lex_ord_pair ko f (sort_oalist_aux ko xs) (sort_oalist_aux ko ys)"
fun prod_ord_raw :: "('a ⇒ 'b ⇒ 'c ⇒ bool) ⇒ ('a, 'b::zero, 'o) oalist_raw ⇒
('a, 'c::zero, 'o) oalist_raw ⇒ bool"
where "prod_ord_raw f (xs, ox) ys = prod_ord_pair ox f xs (sort_oalist_aux ox ys)"
fun oalist_eq_raw :: "('a, 'b, 'o) oalist_raw ⇒ ('a, 'b::zero, 'o) oalist_raw ⇒ bool"
where "oalist_eq_raw (xs, ox) ys = (xs = (sort_oalist_aux ox ys))"
fun sort_oalist_raw :: "('a, 'b, 'o) oalist_raw ⇒ ('a, 'b::zero, 'o) oalist_raw"
where "sort_oalist_raw (xs, ko) = (sort_oalist ko xs, ko)"
subsubsection ‹@{const sort_oalist_aux}›
lemma set_sort_oalist_aux:
assumes "oalist_inv xs"
shows "set (sort_oalist_aux ko xs) = set (fst xs)"
proof -
obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
interpret ko2: comparator2 "key_compare (rep_key_order ko)" "key_compare (rep_key_order ko')" ..
from assms show ?thesis by (simp add: xs oalist_inv_alt ko2.set_sort_oalist)
qed
lemma oalist_inv_raw_sort_oalist_aux:
assumes "oalist_inv xs"
shows "oalist_inv_raw ko (sort_oalist_aux ko xs)"
proof -
obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
from assms show ?thesis by (simp add: xs oalist_inv_alt oalist_inv_raw_sort_oalist)
qed
lemma oalist_inv_sort_oalist_aux:
assumes "oalist_inv xs"
shows "oalist_inv (sort_oalist_aux ko xs, ko)"
unfolding oalist_inv_alt using assms by (rule oalist_inv_raw_sort_oalist_aux)
lemma lookup_pair_sort_oalist_aux:
assumes "oalist_inv xs"
shows "lookup_pair ko (sort_oalist_aux ko xs) = lookup_raw xs"
proof -
obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
interpret ko2: comparator2 "key_compare (rep_key_order ko)" "key_compare (rep_key_order ko')" ..
from assms show ?thesis by (simp add: xs oalist_inv_alt ko2.lookup_pair_sort_oalist)
qed
subsubsection ‹@{const lookup_raw}›
lemma lookup_raw_eq_value:
assumes "oalist_inv xs" and "v ≠ 0"
shows "lookup_raw xs k = v ⟷ ((k, v) ∈ set (fst xs))"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_def)
show ?thesis by (simp add: xs, rule lookup_pair_eq_value, fact+)
qed
lemma lookup_raw_eq_valueI:
assumes "oalist_inv xs" and "(k, v) ∈ set (fst xs)"
shows "lookup_raw xs k = v"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_def)
from assms(2) have "(k, v) ∈ set xs'" by (simp add: xs)
show ?thesis by (simp add: xs, rule lookup_pair_eq_valueI, fact+)
qed
lemma lookup_raw_inj:
assumes "oalist_inv (xs, ko)" and "oalist_inv (ys, ko)" and "lookup_raw (xs, ko) = lookup_raw (ys, ko)"
shows "xs = ys"
using assms unfolding lookup_raw.simps oalist_inv_alt by (rule lookup_pair_inj)
subsubsection ‹@{const sorted_domain_raw}›
lemma set_sorted_domain_raw:
assumes "oalist_inv xs"
shows "set (sorted_domain_raw ko xs) = fst ` set (fst xs)"
using assms by (simp add: sorted_domain_raw_def set_sort_oalist_aux)
corollary in_sorted_domain_raw_iff_lookup_raw:
assumes "oalist_inv xs"
shows "k ∈ set (sorted_domain_raw ko xs) ⟷ (lookup_raw xs k ≠ 0)"
unfolding set_sorted_domain_raw[OF assms]
proof -
obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
from assms show "k ∈ fst ` set (fst xs) ⟷ (lookup_raw xs k ≠ 0)"
by (simp add: xs oalist_inv_alt lookup_pair_eq_0)
qed
lemma sorted_sorted_domain_raw:
assumes "oalist_inv xs"
shows "sorted_wrt (lt_of_key_order (rep_key_order ko)) (sorted_domain_raw ko xs)"
unfolding sorted_domain_raw_def oalist_inv_alt lt_of_key_order.rep_eq
by (rule oalist_inv_rawD2, rule oalist_inv_raw_sort_oalist_aux, fact)
subsubsection ‹@{const tl_raw}›
lemma oalist_inv_tl_raw:
assumes "oalist_inv xs"
shows "oalist_inv (tl_raw xs)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms show ?thesis unfolding xs tl_raw.simps oalist_inv_alt by (rule oalist_inv_raw_tl)
qed
lemma lookup_raw_tl_raw:
assumes "oalist_inv xs"
shows "lookup_raw (tl_raw xs) k =
(if (∀k'∈fst ` set (fst xs). le (snd xs) k k') then 0 else lookup_raw xs k)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms show ?thesis by (simp add: xs lookup_pair_tl oalist_inv_alt split del: if_split cong: if_cong)
qed
lemma lookup_raw_tl_raw':
assumes "oalist_inv xs"
shows "lookup_raw (tl_raw xs) k = (if k = fst (List.hd (fst xs)) then 0 else lookup_raw xs k)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms show ?thesis by (simp add: xs lookup_pair_tl' oalist_inv_alt)
qed
subsubsection ‹@{const min_key_val_raw}›
lemma min_key_val_raw_alt:
assumes "oalist_inv xs" and "fst xs ≠ []"
shows "min_key_val_raw ko xs = List.hd (sort_oalist_aux ko xs)"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
from assms(2) have "xs' ≠ []" by (simp add: xs)
interpret ko2: comparator2 "key_compare (rep_key_order ko)" "key_compare (rep_key_order ox)" ..
from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
hence set_sort: "set (sort_oalist ko xs') = set xs'" by (rule ko2.set_sort_oalist)
also from ‹xs' ≠ []› have "... ≠ {}" by simp
finally have "sort_oalist ko xs' ≠ []" by simp
then obtain k v xs'' where eq: "sort_oalist ko xs' = (k, v) # xs''"
using prod.exhaust list.exhaust by metis
hence "(k, v) ∈ set xs'" by (simp add: set_sort[symmetric])
have *: "le ko k k'" if "k' ∈ fst ` set xs'" for k'
proof -
from that have "k' = k ∨ k' ∈ fst ` set xs''" by (simp add: set_sort[symmetric] eq)
thus ?thesis
proof
assume "k' = k"
thus ?thesis by simp
next
have "oalist_inv_raw ko ((k, v) # xs'')" unfolding eq[symmetric] by (fact oalist_inv_raw_sort_oalist)
moreover assume "k' ∈ fst ` set xs''"
ultimately have "lt ko k k'" by (rule oalist_inv_raw_ConsD3)
thus ?thesis by simp
qed
qed
from ‹xs' ≠ []› have "min_list_param (λx y. le ko (fst x) (fst y)) xs' ∈ set xs'" by (rule min_list_param_in)
with ‹oalist_inv_raw ox xs'› have "lookup_pair ox xs' (fst (min_list_param (λx y. le ko (fst x) (fst y)) xs')) =
snd (min_list_param (λx y. le ko (fst x) (fst y)) xs')" by (auto intro: lookup_pair_eq_valueI)
moreover have 1: "fst (min_list_param (λx y. le ko (fst x) (fst y)) xs') = k"
proof (rule antisym)
from order.trans
have "transp (λx y. le ko (fst x) (fst y))" by (rule transpI)
hence "le ko (fst (min_list_param (λx y. le ko (fst x) (fst y)) xs')) (fst (k, v))"
using linear ‹(k, v) ∈ set xs'› by (rule min_list_param_minimal)
thus "le ko (fst (min_list_param (λx y. le ko (fst x) (fst y)) xs')) k" by simp
next
show "le ko k (fst (min_list_param (λx y. le ko (fst x) (fst y)) xs'))" by (rule *, rule imageI, fact)
qed
ultimately have "snd (min_list_param (λx y. le ko (fst x) (fst y)) xs') = lookup_pair ox xs' k"
by simp
also from ‹oalist_inv_raw ox xs'› ‹(k, v) ∈ set xs'› have "... = v" by (rule lookup_pair_eq_valueI)
finally have "snd (min_list_param (λx y. le ko (fst x) (fst y)) xs') = v" .
with 1 have "min_list_param (λx y. le ko (fst x) (fst y)) xs' = (k, v)" by auto
thus ?thesis by (simp add: xs eq)
qed
lemma min_key_val_raw_in:
assumes "fst xs ≠ []"
shows "min_key_val_raw ko xs ∈ set (fst xs)"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
from assms have "xs' ≠ []" by (simp add: xs)
show ?thesis unfolding xs
proof (simp, intro conjI impI)
from ‹xs' ≠ []› show "hd xs' ∈ set xs'" by simp
next
from ‹xs' ≠ []› show "min_list_param (λx y. le ko (fst x) (fst y)) xs' ∈ set xs'"
by (rule min_list_param_in)
qed
qed
lemma snd_min_key_val_raw:
assumes "oalist_inv xs" and "fst xs ≠ []"
shows "snd (min_key_val_raw ko xs) = lookup_raw xs (fst (min_key_val_raw ko xs))"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
from assms(2) have "min_key_val_raw ko xs ∈ set (fst xs)" by (rule min_key_val_raw_in)
hence *: "min_key_val_raw ko (xs', ox) ∈ set xs'" by (simp add: xs)
show ?thesis unfolding xs lookup_raw.simps
by (rule HOL.sym, rule lookup_pair_eq_valueI, fact, simp add: * del: min_key_val_raw.simps)
qed
lemma min_key_val_raw_minimal:
assumes "oalist_inv xs" and "z ∈ set (fst xs)"
shows "le ko (fst (min_key_val_raw ko xs)) (fst z)"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
from assms have "oalist_inv (xs', ox)" and "z ∈ set xs'" by (simp_all add: xs)
show ?thesis unfolding xs
proof (simp, intro conjI impI)
from ‹z ∈ set xs'› have "xs' ≠ []" by auto
then obtain k v ys where xs': "xs' = (k, v) # ys" using prod.exhaust list.exhaust by metis
from ‹z ∈ set xs'› have "z = (k, v) ∨ z ∈ set ys" by (simp add: xs')
thus "le ox (fst (hd xs')) (fst z)"
proof
assume "z = (k, v)"
show ?thesis by (simp add: xs' ‹z = (k, v)›)
next
assume "z ∈ set ys"
hence "fst z ∈ fst ` set ys" by fastforce
with ‹oalist_inv (xs', ox)› have "lt ox k (fst z)"
unfolding xs' oalist_inv_alt lt_of_key_order.rep_eq by (rule oalist_inv_raw_ConsD3)
thus ?thesis by (simp add: xs')
qed
next
show "le ko (fst (min_list_param (λx y. le ko (fst x) (fst y)) xs')) (fst z)"
proof (rule min_list_param_minimal[of "λx y. le ko (fst x) (fst y)"])
show "transp (λx y. le ko (fst x) (fst y))" by (metis (no_types, lifting) order.trans transpI)
qed (auto intro: ‹z ∈ set xs'›)
qed
qed
subsubsection ‹@{const filter_raw}›
lemma oalist_inv_filter_raw:
assumes "oalist_inv xs"
shows "oalist_inv (filter_raw P xs)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms show ?thesis unfolding xs filter_raw.simps oalist_inv_alt
by (rule oalist_inv_raw_filter)
qed
lemma lookup_raw_filter_raw:
assumes "oalist_inv xs"
shows "lookup_raw (filter_raw P xs) k = (let v = lookup_raw xs k in if P (k, v) then v else 0)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms show ?thesis unfolding xs lookup_raw.simps filter_raw.simps oalist_inv_alt
by (rule lookup_pair_filter)
qed
subsubsection ‹@{const update_by_raw}›
lemma oalist_inv_update_by_raw:
assumes "oalist_inv xs"
shows "oalist_inv (update_by_raw kv xs)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms show ?thesis unfolding xs update_by_raw.simps oalist_inv_alt
by (rule oalist_inv_raw_update_by_pair)
qed
lemma lookup_raw_update_by_raw:
assumes "oalist_inv xs"
shows "lookup_raw (update_by_raw (k1, v) xs) k2 = (if k1 = k2 then v else lookup_raw xs k2)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms show ?thesis unfolding xs lookup_raw.simps update_by_raw.simps oalist_inv_alt
by (rule lookup_pair_update_by_pair)
qed
subsubsection ‹@{const update_by_fun_raw} and @{const update_by_fun_gr_raw}›
lemma update_by_fun_raw_eq_update_by_raw:
assumes "oalist_inv xs"
shows "update_by_fun_raw k f xs = update_by_raw (k, f (lookup_raw xs k)) xs"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
show ?thesis unfolding xs update_by_fun_raw.simps lookup_raw.simps update_by_raw.simps
by (rule, rule conjI, rule update_by_fun_pair_eq_update_by_pair, fact, fact refl)
qed
corollary oalist_inv_update_by_fun_raw:
assumes "oalist_inv xs"
shows "oalist_inv (update_by_fun_raw k f xs)"
unfolding update_by_fun_raw_eq_update_by_raw[OF assms] using assms by (rule oalist_inv_update_by_raw)
corollary lookup_raw_update_by_fun_raw:
assumes "oalist_inv xs"
shows "lookup_raw (update_by_fun_raw k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_raw xs k2)"
using assms by (simp add: update_by_fun_raw_eq_update_by_raw lookup_raw_update_by_raw)
lemma update_by_fun_gr_raw_eq_update_by_fun_raw:
assumes "oalist_inv xs"
shows "update_by_fun_gr_raw k f xs = update_by_fun_raw k f xs"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
show ?thesis unfolding xs update_by_fun_raw.simps lookup_raw.simps update_by_fun_gr_raw.simps
by (rule, rule conjI, rule update_by_fun_gr_pair_eq_update_by_fun_pair, fact, fact refl)
qed
corollary oalist_inv_update_by_fun_gr_raw:
assumes "oalist_inv xs"
shows "oalist_inv (update_by_fun_gr_raw k f xs)"
unfolding update_by_fun_gr_raw_eq_update_by_fun_raw[OF assms] using assms by (rule oalist_inv_update_by_fun_raw)
corollary lookup_raw_update_by_fun_gr_raw:
assumes "oalist_inv xs"
shows "lookup_raw (update_by_fun_gr_raw k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_raw xs k2)"
using assms by (simp add: update_by_fun_gr_raw_eq_update_by_fun_raw lookup_raw_update_by_fun_raw)
subsubsection ‹@{const map_raw} and @{const map_val_raw}›
lemma map_raw_cong:
assumes "⋀kv. kv ∈ set (fst xs) ⟹ f kv = g kv"
shows "map_raw f xs = map_raw g xs"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms have "f kv = g kv" if "kv ∈ set xs'" for kv using that by (simp add: xs)
thus ?thesis by (simp add: xs, rule map_pair_cong)
qed
lemma map_raw_subset: "set (fst (map_raw f xs)) ⊆ f ` set (fst xs)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
show ?thesis by (simp add: xs map_pair_subset)
qed
lemma oalist_inv_map_raw:
assumes "oalist_inv xs"
and "⋀a b. key_compare (rep_key_order (snd xs)) (fst (f a)) (fst (f b)) = key_compare (rep_key_order (snd xs)) (fst a) (fst b)"
shows "oalist_inv (map_raw f xs)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms(1) have "oalist_inv (xs', ko)" by (simp only: xs)
moreover from assms(2)
have "⋀a b. key_compare (rep_key_order ko) (fst (f a)) (fst (f b)) = key_compare (rep_key_order ko) (fst a) (fst b)"
by (simp add: xs)
ultimately show ?thesis unfolding xs map_raw.simps oalist_inv_alt by (rule oalist_inv_raw_map_pair)
qed
lemma lookup_raw_map_raw:
assumes "oalist_inv xs" and "snd (f (k, 0)) = 0"
and "⋀a b. key_compare (rep_key_order (snd xs)) (fst (f a)) (fst (f b)) = key_compare (rep_key_order (snd xs)) (fst a) (fst b)"
shows "lookup_raw (map_raw f xs) (fst (f (k, v))) = snd (f (k, lookup_raw xs k))"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms(1) have "oalist_inv (xs', ko)" by (simp only: xs)
moreover note assms(2)
moreover from assms(3)
have "⋀a b. key_compare (rep_key_order ko) (fst (f a)) (fst (f b)) = key_compare (rep_key_order ko) (fst a) (fst b)"
by (simp add: xs)
ultimately show ?thesis unfolding xs lookup_raw.simps map_raw.simps oalist_inv_alt
by (rule lookup_pair_map_pair)
qed
lemma map_raw_id:
assumes "oalist_inv xs"
shows "map_raw id xs = xs"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
hence "map_pair id xs' = xs'"
proof (induct xs' rule: oalist_inv_raw_induct)
case Nil
show ?case by simp
next
case (Cons k v xs')
show ?case by (simp add: Let_def Cons(3, 5) id_def[symmetric])
qed
thus ?thesis by (simp add: xs)
qed
lemma map_val_raw_cong:
assumes "⋀k v. (k, v) ∈ set (fst xs) ⟹ f k v = g k v"
shows "map_val_raw f xs = map_val_raw g xs"
proof (rule map_raw_cong)
fix kv
assume "kv ∈ set (fst xs)"
moreover obtain k v where "kv = (k, v)" by fastforce
ultimately show "(case kv of (k, v) ⇒ (k, f k v)) = (case kv of (k, v) ⇒ (k, g k v))"
by (simp add: assms)
qed
lemma oalist_inv_map_val_raw:
assumes "oalist_inv xs"
shows "oalist_inv (map_val_raw f xs)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms show ?thesis unfolding xs map_raw.simps oalist_inv_alt by (rule oalist_inv_raw_map_val_pair)
qed
lemma lookup_raw_map_val_raw:
assumes "oalist_inv xs" and "f k 0 = 0"
shows "lookup_raw (map_val_raw f xs) k = f k (lookup_raw xs k)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms show ?thesis unfolding xs map_raw.simps lookup_raw.simps oalist_inv_alt
by (rule lookup_pair_map_val_pair)
qed
subsubsection ‹@{const map2_val_raw}›
definition map2_val_compat' :: "(('a, 'b::zero, 'o) oalist_raw ⇒ ('a, 'c::zero, 'o) oalist_raw) ⇒ bool"
where "map2_val_compat' f ⟷
(∀zs. (oalist_inv zs ⟶ (oalist_inv (f zs) ∧ snd (f zs) = snd zs ∧ fst ` set (fst (f zs)) ⊆ fst ` set (fst zs))))"
lemma map2_val_compat'I:
assumes "⋀zs. oalist_inv zs ⟹ oalist_inv (f zs)"
and "⋀zs. oalist_inv zs ⟹ snd (f zs) = snd zs"
and "⋀zs. oalist_inv zs ⟹ fst ` set (fst (f zs)) ⊆ fst ` set (fst zs)"
shows "map2_val_compat' f"
unfolding map2_val_compat'_def using assms by blast
lemma map2_val_compat'D1:
assumes "map2_val_compat' f" and "oalist_inv zs"
shows "oalist_inv (f zs)"
using assms unfolding map2_val_compat'_def by blast
lemma map2_val_compat'D2:
assumes "map2_val_compat' f" and "oalist_inv zs"
shows "snd (f zs) = snd zs"
using assms unfolding map2_val_compat'_def by blast
lemma map2_val_compat'D3:
assumes "map2_val_compat' f" and "oalist_inv zs"
shows "fst ` set (fst (f zs)) ⊆ fst ` set (fst zs)"
using assms unfolding map2_val_compat'_def by blast
lemma map2_val_compat'_map_val_raw: "map2_val_compat' (map_val_raw f)"
proof (rule map2_val_compat'I, erule oalist_inv_map_val_raw)
fix zs::"('a, 'b, 'o) oalist_raw"
obtain zs' ko where "zs = (zs', ko)" by fastforce
thus "snd (map_val_raw f zs) = snd zs" by simp
next
fix zs::"('a, 'b, 'o) oalist_raw"
obtain zs' ko where zs: "zs = (zs', ko)" by fastforce
show "fst ` set (fst (map_val_raw f zs)) ⊆ fst ` set (fst zs)"
proof (simp add: zs)
from map_pair_subset have "fst ` set (map_val_pair f zs') ⊆ fst ` (λ(k, v). (k, f k v)) ` set zs'"
by (rule image_mono)
also have "... = fst ` set zs'" by force
finally show "fst ` set (map_val_pair f zs') ⊆ fst ` set zs'" .
qed
qed
lemma map2_val_compat'_id: "map2_val_compat' id"
by (rule map2_val_compat'I, auto)
lemma map2_val_compat'_imp_map2_val_compat:
assumes "map2_val_compat' g"
shows "map2_val_compat ko (λzs. fst (g (zs, ko)))"
proof (rule map2_val_compatI)
fix zs::"('a × 'b) list"
assume a: "oalist_inv_raw ko zs"
hence "oalist_inv (zs, ko)" by (simp only: oalist_inv_alt)
with assms have "oalist_inv (g (zs, ko))" by (rule map2_val_compat'D1)
hence "oalist_inv (fst (g (zs, ko)), snd (g (zs, ko)))" by simp
thus "oalist_inv_raw ko (fst (g (zs, ko)))" using assms a by (simp add: oalist_inv_alt map2_val_compat'D2)
next
fix zs::"('a × 'b) list"
assume a: "oalist_inv_raw ko zs"
hence "oalist_inv (zs, ko)" by (simp only: oalist_inv_alt)
with assms have "fst ` set (fst (g (zs, ko))) ⊆ fst ` set (fst (zs, ko))" by (rule map2_val_compat'D3)
thus "fst ` set (fst (g (zs, ko))) ⊆ fst ` set zs" by simp
qed
lemma oalist_inv_map2_val_raw:
assumes "oalist_inv xs" and "oalist_inv ys"
assumes "map2_val_compat' g" and "map2_val_compat' h"
shows "oalist_inv (map2_val_raw f g h xs ys)"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
let ?ys = "sort_oalist_aux ox ys"
from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_alt)
moreover from assms(2) have "oalist_inv_raw ox (sort_oalist_aux ox ys)"
by (rule oalist_inv_raw_sort_oalist_aux)
moreover from assms(3) have "map2_val_compat ko (λzs. fst (g (zs, ko)))" for ko
by (rule map2_val_compat'_imp_map2_val_compat)
moreover from assms(4) have "map2_val_compat ko (λzs. fst (h (zs, ko)))" for ko
by (rule map2_val_compat'_imp_map2_val_compat)
ultimately have "oalist_inv_raw ox (map2_val_pair ox f (λzs. fst (g (zs, ox))) (λzs. fst (h (zs, ox))) xs' ?ys)"
by (rule oalist_inv_raw_map2_val_pair)
thus ?thesis by (simp add: xs oalist_inv_alt)
qed
lemma lookup_raw_map2_val_raw:
assumes "oalist_inv xs" and "oalist_inv ys"
assumes "map2_val_compat' g" and "map2_val_compat' h"
assumes "⋀zs. oalist_inv zs ⟹ g zs = map_val_raw (λk v. f k v 0) zs"
and "⋀zs. oalist_inv zs ⟹ h zs = map_val_raw (λk. f k 0) zs"
and "⋀k. f k 0 0 = 0"
shows "lookup_raw (map2_val_raw f g h xs ys) k0 = f k0 (lookup_raw xs k0) (lookup_raw ys k0)"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
let ?ys = "sort_oalist_aux ox ys"
from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_alt)
moreover from assms(2) have "oalist_inv_raw ox (sort_oalist_aux ox ys)" by (rule oalist_inv_raw_sort_oalist_aux)
moreover from assms(3) have "map2_val_compat ko (λzs. fst (g (zs, ko)))" for ko
by (rule map2_val_compat'_imp_map2_val_compat)
moreover from assms(4) have "map2_val_compat ko (λzs. fst (h (zs, ko)))" for ko
by (rule map2_val_compat'_imp_map2_val_compat)
ultimately have "lookup_pair ox (map2_val_pair ox f (λzs. fst (g (zs, ox))) (λzs. fst (h (zs, ox))) xs' ?ys) k0 =
f k0 (lookup_pair ox xs' k0) (lookup_pair ox ?ys k0)" using _ _ assms(7)
proof (rule lookup_pair_map2_val_pair)
fix zs::"('a × 'b) list"
assume "oalist_inv_raw ox zs"
hence "oalist_inv (zs, ox)" by (simp only: oalist_inv_alt)
hence "g (zs, ox) = map_val_raw (λk v. f k v 0) (zs, ox)" by (rule assms(5))
thus "fst (g (zs, ox)) = map_val_pair (λk v. f k v 0) zs" by simp
next
fix zs::"('a × 'c) list"
assume "oalist_inv_raw ox zs"
hence "oalist_inv (zs, ox)" by (simp only: oalist_inv_alt)
hence "h (zs, ox) = map_val_raw (λk. f k 0) (zs, ox)" by (rule assms(6))
thus "fst (h (zs, ox)) = map_val_pair (λk. f k 0) zs" by simp
qed
also from assms(2) have "... = f k0 (lookup_pair ox xs' k0) (lookup_raw ys k0)"
by (simp only: lookup_pair_sort_oalist_aux)
finally have *: "lookup_pair ox (map2_val_pair ox f (λzs. fst (g (zs, ox))) (λzs. fst (h (zs, ox))) xs' ?ys) k0 =
f k0 (lookup_pair ox xs' k0) (lookup_raw ys k0)" .
thus ?thesis by (simp add: xs)
qed
lemma map2_val_raw_singleton_eq_update_by_fun_raw:
assumes "oalist_inv xs"
assumes "⋀k x. f k x 0 = x" and "⋀zs. oalist_inv zs ⟹ g zs = zs"
and "⋀ko. h ([(k, v)], ko) = map_val_raw (λk. f k 0) ([(k, v)], ko)"
shows "map2_val_raw f g h xs ([(k, v)], ko) = update_by_fun_raw k (λx. f k x v) xs"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
let ?ys = "sort_oalist ox [(k, v)]"
from assms(1) have inv: "oalist_inv (xs', ox)" by (simp only: xs)
hence inv_raw: "oalist_inv_raw ox xs'" by (simp only: oalist_inv_alt)
show ?thesis
proof (simp add: xs, intro conjI impI)
assume "ox = ko"
from inv_raw have "oalist_inv_raw ko xs'" by (simp only: ‹ox = ko›)
thus "map2_val_pair ko f (λzs. fst (g (zs, ko))) (λzs. fst (h (zs, ko))) xs' [(k, v)] =
update_by_fun_pair ko k (λx. f k x v) xs'"
using assms(2)
proof (rule map2_val_pair_singleton_eq_update_by_fun_pair)
fix zs::"('a × 'b) list"
assume "oalist_inv_raw ko zs"
hence "oalist_inv (zs, ko)" by (simp only: oalist_inv_alt)
hence "g (zs, ko) = (zs, ko)" by (rule assms(3))
thus "fst (g (zs, ko)) = zs" by simp
next
show "fst (h ([(k, v)], ko)) = map_val_pair (λk. f k 0) [(k, v)]" by (simp add: assms(4))
qed
next
show "map2_val_pair ox f (λzs. fst (g (zs, ox))) (λzs. fst (h (zs, ox))) xs' (sort_oalist ox [(k, v)]) =
update_by_fun_pair ox k (λx. f k x v) xs'"
proof (cases "v = 0")
case True
have eq1: "sort_oalist ox [(k, 0)] = []" by (simp add: sort_oalist_def)
from inv have eq2: "g (xs', ox) = (xs', ox)" by (rule assms(3))
show ?thesis
by (simp add: True eq1 eq2 assms(2) update_by_fun_pair_eq_update_by_pair[OF inv_raw],
rule HOL.sym, rule update_by_pair_id, fact inv_raw, fact refl)
next
case False
hence "oalist_inv_raw ox [(k, v)]" by (simp add: oalist_inv_raw_singleton)
hence eq: "sort_oalist ox [(k, v)] = [(k, v)]" by (rule sort_oalist_id)
show ?thesis unfolding eq using inv_raw assms(2)
proof (rule map2_val_pair_singleton_eq_update_by_fun_pair)
fix zs::"('a × 'b) list"
assume "oalist_inv_raw ox zs"
hence "oalist_inv (zs, ox)" by (simp only: oalist_inv_alt)
hence "g (zs, ox) = (zs, ox)" by (rule assms(3))
thus "fst (g (zs, ox)) = zs" by simp
next
show "fst (h ([(k, v)], ox)) = map_val_pair (λk. f k 0) [(k, v)]" by (simp add: assms(4))
qed
qed
qed
qed
subsubsection ‹@{const lex_ord_raw}›
lemma lex_ord_raw_EqI:
assumes "oalist_inv xs" and "oalist_inv ys"
and "⋀k. k ∈ fst ` set (fst xs) ∪ fst ` set (fst ys) ⟹ f k (lookup_raw xs k) (lookup_raw ys k) = Some Eq"
shows "lex_ord_raw ko f xs ys = Some Eq"
unfolding lex_ord_raw_def
by (rule lex_ord_pair_EqI, simp_all add: assms oalist_inv_raw_sort_oalist_aux lookup_pair_sort_oalist_aux set_sort_oalist_aux)
lemma lex_ord_raw_valI:
assumes "oalist_inv xs" and "oalist_inv ys" and "aux ≠ Some Eq"
assumes "k ∈ fst ` set (fst xs) ∪ fst ` set (fst ys)" and "aux = f k (lookup_raw xs k) (lookup_raw ys k)"
and "⋀k'. k' ∈ fst ` set (fst xs) ∪ fst ` set (fst ys) ⟹ lt ko k' k ⟹
f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq"
shows "lex_ord_raw ko f xs ys = aux"
unfolding lex_ord_raw_def
using oalist_inv_sort_oalist_aux[OF assms(1)] oalist_inv_raw_sort_oalist_aux[OF assms(2)] assms(3)
unfolding oalist_inv_alt
proof (rule lex_ord_pair_valI)
from assms(1, 2, 4) show "k ∈ fst ` set (sort_oalist_aux ko xs) ∪ fst ` set (sort_oalist_aux ko ys)"
by (simp add: set_sort_oalist_aux)
next
from assms(1, 2, 5) show "aux = f k (lookup_pair ko (sort_oalist_aux ko xs) k) (lookup_pair ko (sort_oalist_aux ko ys) k)"
by (simp add: lookup_pair_sort_oalist_aux)
next
fix k'
assume "k' ∈ fst ` set (sort_oalist_aux ko xs) ∪ fst ` set (sort_oalist_aux ko ys)"
with assms(1, 2) have "k' ∈ fst ` set (fst xs) ∪ fst ` set (fst ys)" by (simp add: set_sort_oalist_aux)
moreover assume "lt ko k' k"
ultimately have "f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq" by (rule assms(6))
with assms(1, 2) show "f k' (lookup_pair ko (sort_oalist_aux ko xs) k') (lookup_pair ko (sort_oalist_aux ko ys) k') = Some Eq"
by (simp add: lookup_pair_sort_oalist_aux)
qed
lemma lex_ord_raw_EqD:
assumes "oalist_inv xs" and "oalist_inv ys" and "lex_ord_raw ko f xs ys = Some Eq"
and "k ∈ fst ` set (fst xs) ∪ fst ` set (fst ys)"
shows "f k (lookup_raw xs k) (lookup_raw ys k) = Some Eq"
proof -
have "f k (lookup_pair ko (sort_oalist_aux ko xs) k) (lookup_pair ko (sort_oalist_aux ko ys) k) = Some Eq"
by (rule lex_ord_pair_EqD[where f=f],
simp_all add: oalist_inv_raw_sort_oalist_aux assms lex_ord_raw_def[symmetric] set_sort_oalist_aux del: Un_iff)
with assms(1, 2) show ?thesis by (simp add: lookup_pair_sort_oalist_aux)
qed
lemma lex_ord_raw_valE:
assumes "oalist_inv xs" and "oalist_inv ys" and "lex_ord_raw ko f xs ys = aux"
and "aux ≠ Some Eq"
obtains k where "k ∈ fst ` set (fst xs) ∪ fst ` set (fst ys)"
and "aux = f k (lookup_raw xs k) (lookup_raw ys k)"
and "⋀k'. k' ∈ fst ` set (fst xs) ∪ fst ` set (fst ys) ⟹ lt ko k' k ⟹
f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq"
proof -
let ?xs = "sort_oalist_aux ko xs"
let ?ys = "sort_oalist_aux ko ys"
from assms(3) have "lex_ord_pair ko f ?xs ?ys = aux" by (simp only: lex_ord_raw_def)
with oalist_inv_sort_oalist_aux[OF assms(1)] oalist_inv_sort_oalist_aux[OF assms(2)]
obtain k where a: "k ∈ fst ` set ?xs ∪ fst ` set ?ys"
and b: "aux = f k (lookup_pair ko ?xs k) (lookup_pair ko ?ys k)"
and c: "⋀k'. k' ∈ fst ` set ?xs ∪ fst ` set ?ys ⟹ lt ko k' k ⟹
f k' (lookup_pair ko ?xs k') (lookup_pair ko ?ys k') = Some Eq"
using assms(4) unfolding oalist_inv_alt by (rule lex_ord_pair_valE, blast)
from a have "k ∈ fst ` set (fst xs) ∪ fst ` set (fst ys)"
by (simp add: set_sort_oalist_aux assms(1, 2))
moreover from b have "aux = f k (lookup_raw xs k) (lookup_raw ys k)"
by (simp add: lookup_pair_sort_oalist_aux assms(1, 2))
moreover have "f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq"
if k'_in: "k' ∈ fst ` set (fst xs) ∪ fst ` set (fst ys)" and k'_less: "lt ko k' k" for k'
proof -
have "f k' (lookup_raw xs k') (lookup_raw ys k') = f k' (lookup_pair ko ?xs k') (lookup_pair ko ?ys k')"
by (simp add: lookup_pair_sort_oalist_aux assms(1, 2))
also have "... = Some Eq"
proof (rule c)
from k'_in show "k' ∈ fst ` set ?xs ∪ fst ` set ?ys"
by (simp add: set_sort_oalist_aux assms(1, 2))
next
from k'_less show "lt ko k' k" by (simp only: lt_of_key_order.rep_eq)
qed
finally show ?thesis .
qed
ultimately show ?thesis ..
qed
subsubsection ‹@{const prod_ord_raw}›
lemma prod_ord_rawI:
assumes "oalist_inv xs" and "oalist_inv ys"
and "⋀k. k ∈ fst ` set (fst xs) ∪ fst ` set (fst ys) ⟹ P k (lookup_raw xs k) (lookup_raw ys k)"
shows "prod_ord_raw P xs ys"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
hence *: "prod_ord_pair ox P xs' (sort_oalist_aux ox ys)" using oalist_inv_raw_sort_oalist_aux
proof (rule prod_ord_pairI)
fix k
assume "k ∈ fst ` set xs' ∪ fst ` set (sort_oalist_aux ox ys)"
hence "k ∈ fst ` set (fst xs) ∪ fst ` set (fst ys)" by (simp add: xs set_sort_oalist_aux assms(2))
hence "P k (lookup_raw xs k) (lookup_raw ys k)" by (rule assms(3))
thus "P k (lookup_pair ox xs' k) (lookup_pair ox (sort_oalist_aux ox ys) k)"
by (simp add: xs lookup_pair_sort_oalist_aux assms(2))
qed fact
thus ?thesis by (simp add: xs)
qed
lemma prod_ord_rawD:
assumes "oalist_inv xs" and "oalist_inv ys" and "prod_ord_raw P xs ys"
and "k ∈ fst ` set (fst xs) ∪ fst ` set (fst ys)"
shows "P k (lookup_raw xs k) (lookup_raw ys k)"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
moreover note oalist_inv_raw_sort_oalist_aux[OF assms(2)]
moreover from assms(3) have "prod_ord_pair ox P xs' (sort_oalist_aux ox ys)" by (simp add: xs)
moreover from assms(4) have "k ∈ fst ` set xs' ∪ fst ` set (sort_oalist_aux ox ys)"
by (simp add: xs set_sort_oalist_aux assms(2))
ultimately have *: "P k (lookup_pair ox xs' k) (lookup_pair ox (sort_oalist_aux ox ys) k)"
by (rule prod_ord_pairD)
thus ?thesis by (simp add: xs lookup_pair_sort_oalist_aux assms(2))
qed
corollary prod_ord_raw_alt:
assumes "oalist_inv xs" and "oalist_inv ys"
shows "prod_ord_raw P xs ys ⟷
(∀k∈fst ` set (fst xs) ∪ fst ` set (fst ys). P k (lookup_raw xs k) (lookup_raw ys k))"
using prod_ord_rawI[OF assms] prod_ord_rawD[OF assms] by meson
subsubsection ‹@{const oalist_eq_raw}›
lemma oalist_eq_rawI:
assumes "oalist_inv xs" and "oalist_inv ys"
and "⋀k. k ∈ fst ` set (fst xs) ∪ fst ` set (fst ys) ⟹ lookup_raw xs k = lookup_raw ys k"
shows "oalist_eq_raw xs ys"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
hence *: "xs' = sort_oalist_aux ox ys" using oalist_inv_raw_sort_oalist_aux[OF assms(2)]
proof (rule lookup_pair_inj)
show "lookup_pair ox xs' = lookup_pair ox (sort_oalist_aux ox ys)"
proof
fix k
show "lookup_pair ox xs' k = lookup_pair ox (sort_oalist_aux ox ys) k"
proof (cases "k ∈ fst ` set xs' ∪ fst ` set (sort_oalist_aux ox ys)")
case True
hence "k ∈ fst ` set (fst xs) ∪ fst ` set (fst ys)" by (simp add: xs set_sort_oalist_aux assms(2))
hence "lookup_raw xs k = lookup_raw ys k" by (rule assms(3))
thus ?thesis by (simp add: xs lookup_pair_sort_oalist_aux assms(2))
next
case False
hence "k ∉ fst ` set xs'" and "k ∉ fst ` set (sort_oalist_aux ox ys)" by simp_all
with ‹oalist_inv_raw ox xs'› oalist_inv_raw_sort_oalist_aux[OF assms(2)]
have "lookup_pair ox xs' k = 0" and "lookup_pair ox (sort_oalist_aux ox ys) k = 0"
by (simp_all add: lookup_pair_eq_0)
thus ?thesis by simp
qed
qed
qed
thus ?thesis by (simp add: xs)
qed
lemma oalist_eq_rawD:
assumes "oalist_inv ys" and "oalist_eq_raw xs ys"
shows "lookup_raw xs = lookup_raw ys"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
from assms(2) have "xs' = sort_oalist_aux ox ys" by (simp add: xs)
hence "lookup_pair ox xs' = lookup_pair ox (sort_oalist_aux ox ys)" by simp
thus ?thesis by (simp add: xs lookup_pair_sort_oalist_aux assms(1))
qed
lemma oalist_eq_raw_alt:
assumes "oalist_inv xs" and "oalist_inv ys"
shows "oalist_eq_raw xs ys ⟷ (lookup_raw xs = lookup_raw ys)"
using oalist_eq_rawI[OF assms] oalist_eq_rawD[OF assms(2)] by metis
subsubsection ‹@{const sort_oalist_raw}›
lemma oalist_inv_sort_oalist_raw: "oalist_inv (sort_oalist_raw xs)"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
show ?thesis by (simp add: xs oalist_inv_raw_sort_oalist oalist_inv_alt)
qed
lemma sort_oalist_raw_id:
assumes "oalist_inv xs"
shows "sort_oalist_raw xs = xs"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
hence "sort_oalist ko xs' = xs'" by (rule sort_oalist_id)
thus ?thesis by (simp add: xs)
qed
lemma set_sort_oalist_raw:
assumes "distinct (map fst (fst xs))"
shows "set (fst (sort_oalist_raw xs)) = {kv. kv ∈ set (fst xs) ∧ snd kv ≠ 0}"
proof -
obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
from assms have "distinct (map fst xs')" by (simp add: xs)
hence "set (sort_oalist ko xs') = {kv ∈ set xs'. snd kv ≠ 0}" by (rule set_sort_oalist)
thus ?thesis by (simp add: xs)
qed
end
subsection ‹Fundamental Operations on One List›
locale oalist_abstract = oalist_raw rep_key_order for rep_key_order::"'o ⇒ 'a key_order" +
fixes list_of_oalist :: "'x ⇒ ('a, 'b::zero, 'o) oalist_raw"
fixes oalist_of_list :: "('a, 'b, 'o) oalist_raw ⇒ 'x"
assumes oalist_inv_list_of_oalist: "oalist_inv (list_of_oalist x)"
and list_of_oalist_of_list: "list_of_oalist (oalist_of_list xs) = sort_oalist_raw xs"
and oalist_of_list_of_oalist: "oalist_of_list (list_of_oalist x) = x"
begin
lemma list_of_oalist_of_list_id:
assumes "oalist_inv xs"
shows "list_of_oalist (oalist_of_list xs) = xs"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
from assms show ?thesis by (simp add: xs list_of_oalist_of_list sort_oalist_id oalist_inv_alt)
qed
definition lookup :: "'x ⇒ 'a ⇒ 'b"
where "lookup xs = lookup_raw (list_of_oalist xs)"
definition sorted_domain :: "'o ⇒ 'x ⇒ 'a list"
where "sorted_domain ko xs = sorted_domain_raw ko (list_of_oalist xs)"
definition empty :: "'o ⇒ 'x"
where "empty ko = oalist_of_list ([], ko)"
definition reorder :: "'o ⇒ 'x ⇒ 'x"
where "reorder ko xs = oalist_of_list (sort_oalist_aux ko (list_of_oalist xs), ko)"
definition tl :: "'x ⇒ 'x"
where "tl xs = oalist_of_list (tl_raw (list_of_oalist xs))"
definition hd :: "'x ⇒ ('a × 'b)"
where "hd xs = List.hd (fst (list_of_oalist xs))"
definition except_min :: "'o ⇒ 'x ⇒ 'x"
where "except_min ko xs = tl (reorder ko xs)"
definition min_key_val :: "'o ⇒ 'x ⇒ ('a × 'b)"
where "min_key_val ko xs = min_key_val_raw ko (list_of_oalist xs)"
definition insert :: "('a × 'b) ⇒ 'x ⇒ 'x"
where "insert x xs = oalist_of_list (update_by_raw x (list_of_oalist xs))"
definition update_by_fun :: "'a ⇒ ('b ⇒ 'b) ⇒ 'x ⇒ 'x"
where "update_by_fun k f xs = oalist_of_list (update_by_fun_raw k f (list_of_oalist xs))"
definition update_by_fun_gr :: "'a ⇒ ('b ⇒ 'b) ⇒ 'x ⇒ 'x"
where "update_by_fun_gr k f xs = oalist_of_list (update_by_fun_gr_raw k f (list_of_oalist xs))"
definition filter :: "(('a × 'b) ⇒ bool) ⇒ 'x ⇒ 'x"
where "filter P xs = oalist_of_list (filter_raw P (list_of_oalist xs))"
definition map2_val_neutr :: "('a ⇒ 'b ⇒ 'b ⇒ 'b) ⇒ 'x ⇒ 'x ⇒ 'x"
where "map2_val_neutr f xs ys = oalist_of_list (map2_val_raw f id id (list_of_oalist xs) (list_of_oalist ys))"
definition oalist_eq :: "'x ⇒ 'x ⇒ bool"
where "oalist_eq xs ys = oalist_eq_raw (list_of_oalist xs) (list_of_oalist ys)"
subsubsection ‹Invariant›
lemma zero_notin_list_of_oalist: "0 ∉ snd ` set (fst (list_of_oalist xs))"
proof -
from oalist_inv_list_of_oalist have "oalist_inv_raw (snd (list_of_oalist xs)) (fst (list_of_oalist xs))"
by (simp only: oalist_inv_def)
thus ?thesis by (rule oalist_inv_rawD1)
qed
lemma list_of_oalist_sorted: "sorted_wrt (lt (snd (list_of_oalist xs))) (map fst (fst (list_of_oalist xs)))"
proof -
from oalist_inv_list_of_oalist have "oalist_inv_raw (snd (list_of_oalist xs)) (fst (list_of_oalist xs))"
by (simp only: oalist_inv_def)
thus ?thesis by (rule oalist_inv_rawD2)
qed
subsubsection ‹@{const lookup}›
lemma lookup_eq_value: "v ≠ 0 ⟹ lookup xs k = v ⟷ ((k, v) ∈ set (fst (list_of_oalist xs)))"
unfolding lookup_def using oalist_inv_list_of_oalist by (rule lookup_raw_eq_value)
lemma lookup_eq_valueI: "(k, v) ∈ set (fst (list_of_oalist xs)) ⟹ lookup xs k = v"
unfolding lookup_def using oalist_inv_list_of_oalist by (rule lookup_raw_eq_valueI)
lemma lookup_oalist_of_list:
"distinct (map fst xs) ⟹ lookup (oalist_of_list (xs, ko)) = lookup_dflt xs"
by (simp add: list_of_oalist_of_list lookup_def lookup_pair_sort_oalist')
subsubsection ‹@{const sorted_domain}›
lemma set_sorted_domain: "set (sorted_domain ko xs) = fst ` set (fst (list_of_oalist xs))"
unfolding sorted_domain_def using oalist_inv_list_of_oalist by (rule set_sorted_domain_raw)
lemma in_sorted_domain_iff_lookup: "k ∈ set (sorted_domain ko xs) ⟷ (lookup xs k ≠ 0)"
unfolding sorted_domain_def lookup_def using oalist_inv_list_of_oalist
by (rule in_sorted_domain_raw_iff_lookup_raw)
lemma sorted_sorted_domain: "sorted_wrt (lt ko) (sorted_domain ko xs)"
unfolding sorted_domain_def lt_of_key_order.rep_eq[symmetric]
using oalist_inv_list_of_oalist by (rule sorted_sorted_domain_raw)
subsubsection ‹@{const empty} and Singletons›
lemma list_of_oalist_empty [simp, code abstract]: "list_of_oalist (empty ko) = ([], ko)"
by (simp add: empty_def sort_oalist_def list_of_oalist_of_list)
lemma lookup_empty: "lookup (empty ko) k = 0"
by (simp add: lookup_def)
lemma lookup_oalist_of_list_single:
"lookup (oalist_of_list ([(k, v)], ko)) k' = (if k = k' then v else 0)"
by (simp add: lookup_def list_of_oalist_of_list sort_oalist_def key_compare_Eq split: order.split)
subsubsection ‹@{const reorder}›
lemma list_of_oalist_reorder [simp, code abstract]:
"list_of_oalist (reorder ko xs) = (sort_oalist_aux ko (list_of_oalist xs), ko)"
unfolding reorder_def
by (rule list_of_oalist_of_list_id, simp add: oalist_inv_def, rule oalist_inv_raw_sort_oalist_aux, fact oalist_inv_list_of_oalist)
lemma lookup_reorder: "lookup (reorder ko xs) k = lookup xs k"
by (simp add: lookup_def lookup_pair_sort_oalist_aux oalist_inv_list_of_oalist)
subsubsection ‹@{const hd} and @{const tl}›
lemma list_of_oalist_tl [simp, code abstract]: "list_of_oalist (tl xs) = tl_raw (list_of_oalist xs)"
unfolding tl_def
by (rule list_of_oalist_of_list_id, rule oalist_inv_tl_raw, fact oalist_inv_list_of_oalist)
lemma lookup_tl:
"lookup (tl xs) k =
(if (∀k'∈fst ` set (fst (list_of_oalist xs)). le (snd (list_of_oalist xs)) k k') then 0 else lookup xs k)"
by (simp add: lookup_def lookup_raw_tl_raw oalist_inv_list_of_oalist)
lemma hd_in:
assumes "fst (list_of_oalist xs) ≠ []"
shows "hd xs ∈ set (fst (list_of_oalist xs))"
unfolding hd_def using assms by (rule hd_in_set)
lemma snd_hd:
assumes "fst (list_of_oalist xs) ≠ []"
shows "snd (hd xs) = lookup xs (fst (hd xs))"
proof -
from assms have *: "hd xs ∈ set (fst (list_of_oalist xs))" by (rule hd_in)
show ?thesis by (rule HOL.sym, rule lookup_eq_valueI, simp add: *)
qed
lemma lookup_tl': "lookup (tl xs) k = (if k = fst (hd xs) then 0 else lookup xs k)"
by (simp add: lookup_def lookup_raw_tl_raw' oalist_inv_list_of_oalist hd_def)
lemma hd_tl:
assumes "fst (list_of_oalist xs) ≠ []"
shows "list_of_oalist xs = ((hd xs) # (fst (list_of_oalist (tl xs))), snd (list_of_oalist (tl xs)))"
proof -
obtain xs' ko where xs: "list_of_oalist xs = (xs', ko)" by fastforce
from assms obtain x xs'' where xs': "xs' = x # xs''" unfolding xs fst_conv using list.exhaust by blast
show ?thesis by (simp add: xs xs' hd_def)
qed
subsubsection ‹@{const min_key_val}›
lemma min_key_val_alt:
assumes "fst (list_of_oalist xs) ≠ []"
shows "min_key_val ko xs = hd (reorder ko xs)"
using assms oalist_inv_list_of_oalist by (simp add: min_key_val_def hd_def min_key_val_raw_alt)
lemma min_key_val_in:
assumes "fst (list_of_oalist xs) ≠ []"
shows "min_key_val ko xs ∈ set (fst (list_of_oalist xs))"
unfolding min_key_val_def using assms by (rule min_key_val_raw_in)
lemma snd_min_key_val:
assumes "fst (list_of_oalist xs) ≠ []"
shows "snd (min_key_val ko xs) = lookup xs (fst (min_key_val ko xs))"
unfolding lookup_def min_key_val_def using oalist_inv_list_of_oalist assms by (rule snd_min_key_val_raw)
lemma min_key_val_minimal:
assumes "z ∈ set (fst (list_of_oalist xs))"
shows "le ko (fst (min_key_val ko xs)) (fst z)"
unfolding min_key_val_def
by (rule min_key_val_raw_minimal, fact oalist_inv_list_of_oalist, fact)
subsubsection ‹@{const except_min}›
lemma list_of_oalist_except_min [simp, code abstract]:
"list_of_oalist (except_min ko xs) = (List.tl (sort_oalist_aux ko (list_of_oalist xs)), ko)"
by (simp add: except_min_def)
lemma except_min_Nil:
assumes "fst (list_of_oalist xs) = []"
shows "fst (list_of_oalist (except_min ko xs)) = []"
proof -
obtain xs' ox where eq: "list_of_oalist xs = (xs', ox)" by fastforce
from assms have "xs' = []" by (simp add: eq)
show ?thesis by (simp add: eq ‹xs' = []› sort_oalist_def)
qed
lemma lookup_except_min:
"lookup (except_min ko xs) k =
(if (∀k'∈fst ` set (fst (list_of_oalist xs)). le ko k k') then 0 else lookup xs k)"
by (simp add: except_min_def lookup_tl set_sort_oalist_aux oalist_inv_list_of_oalist lookup_reorder)
lemma lookup_except_min':
"lookup (except_min ko xs) k = (if k = fst (min_key_val ko xs) then 0 else lookup xs k)"
proof (cases "fst (list_of_oalist xs) = []")
case True
hence "lookup xs k = 0" by (metis empty_def lookup_empty oalist_of_list_of_oalist prod.collapse)
thus ?thesis by (simp add: lookup_except_min True)
next
case False
thus ?thesis by (simp add: except_min_def lookup_tl' min_key_val_alt lookup_reorder)
qed
subsubsection ‹@{const insert}›
lemma list_of_oalist_insert [simp, code abstract]:
"list_of_oalist (insert x xs) = update_by_raw x (list_of_oalist xs)"
unfolding insert_def
by (rule list_of_oalist_of_list_id, rule oalist_inv_update_by_raw, fact oalist_inv_list_of_oalist)
lemma lookup_insert: "lookup (insert (k, v) xs) k' = (if k = k' then v else lookup xs k')"
by (simp add: lookup_def lookup_raw_update_by_raw oalist_inv_list_of_oalist split del: if_split cong: if_cong)
subsubsection ‹@{const update_by_fun} and @{const update_by_fun_gr}›
lemma list_of_oalist_update_by_fun [simp, code abstract]:
"list_of_oalist (update_by_fun k f xs) = update_by_fun_raw k f (list_of_oalist xs)"
unfolding update_by_fun_def
by (rule list_of_oalist_of_list_id, rule oalist_inv_update_by_fun_raw, fact oalist_inv_list_of_oalist)
lemma lookup_update_by_fun:
"lookup (update_by_fun k f xs) k' = (if k = k' then f else id) (lookup xs k')"
by (simp add: lookup_def lookup_raw_update_by_fun_raw oalist_inv_list_of_oalist split del: if_split cong: if_cong)
lemma list_of_oalist_update_by_fun_gr [simp, code abstract]:
"list_of_oalist (update_by_fun_gr k f xs) = update_by_fun_gr_raw k f (list_of_oalist xs)"
unfolding update_by_fun_gr_def
by (rule list_of_oalist_of_list_id, rule oalist_inv_update_by_fun_gr_raw, fact oalist_inv_list_of_oalist)
lemma update_by_fun_gr_eq_update_by_fun: "update_by_fun_gr = update_by_fun"
by (rule, rule, rule,
simp add: update_by_fun_gr_def update_by_fun_def update_by_fun_gr_raw_eq_update_by_fun_raw oalist_inv_list_of_oalist)
subsubsection ‹@{const filter}›
lemma list_of_oalist_filter [simp, code abstract]:
"list_of_oalist (filter P xs) = filter_raw P (list_of_oalist xs)"
unfolding filter_def
by (rule list_of_oalist_of_list_id, rule oalist_inv_filter_raw, fact oalist_inv_list_of_oalist)
lemma lookup_filter: "lookup (filter P xs) k = (let v = lookup xs k in if P (k, v) then v else 0)"
by (simp add: lookup_def lookup_raw_filter_raw oalist_inv_list_of_oalist)
subsubsection ‹@{const map2_val_neutr}›
lemma list_of_oalist_map2_val_neutr [simp, code abstract]:
"list_of_oalist (map2_val_neutr f xs ys) = map2_val_raw f id id (list_of_oalist xs) (list_of_oalist ys)"
unfolding map2_val_neutr_def
by (rule list_of_oalist_of_list_id, rule oalist_inv_map2_val_raw,
fact oalist_inv_list_of_oalist, fact oalist_inv_list_of_oalist,
fact map2_val_compat'_id, fact map2_val_compat'_id)
lemma lookup_map2_val_neutr:
assumes "⋀k x. f k x 0 = x" and "⋀k x. f k 0 x = x"
shows "lookup (map2_val_neutr f xs ys) k = f k (lookup xs k) (lookup ys k)"
proof (simp add: lookup_def, rule lookup_raw_map2_val_raw)
fix zs::"('a, 'b, 'o) oalist_raw"
assume "oalist_inv zs"
thus "id zs = map_val_raw (λk v. f k v 0) zs" by (simp add: assms(1) map_raw_id)
next
fix zs::"('a, 'b, 'o) oalist_raw"
assume "oalist_inv zs"
thus "id zs = map_val_raw (λk. f k 0) zs" by (simp add: assms(2) map_raw_id)
qed (fact oalist_inv_list_of_oalist, fact oalist_inv_list_of_oalist,
fact map2_val_compat'_id, fact map2_val_compat'_id, simp only: assms(1))
subsubsection ‹@{const oalist_eq}›
lemma oalist_eq_alt: "oalist_eq xs ys ⟷ (lookup xs = lookup ys)"
by (simp add: oalist_eq_def lookup_def oalist_eq_raw_alt oalist_inv_list_of_oalist)
end
subsection ‹Fundamental Operations on Three Lists›
locale oalist_abstract3 =
oalist_abstract rep_key_order list_of_oalistx oalist_of_listx +
oay: oalist_abstract rep_key_order list_of_oalisty oalist_of_listy +
oaz: oalist_abstract rep_key_order list_of_oalistz oalist_of_listz
for rep_key_order :: "'o ⇒ 'a key_order"
and list_of_oalistx :: "'x ⇒ ('a, 'b::zero, 'o) oalist_raw"
and oalist_of_listx :: "('a, 'b, 'o) oalist_raw ⇒ 'x"
and list_of_oalisty :: "'y ⇒ ('a, 'c::zero, 'o) oalist_raw"
and oalist_of_listy :: "('a, 'c, 'o) oalist_raw ⇒ 'y"
and list_of_oalistz :: "'z ⇒ ('a, 'd::zero, 'o) oalist_raw"
and oalist_of_listz :: "('a, 'd, 'o) oalist_raw ⇒ 'z"
begin
definition map_val :: "('a ⇒ 'b ⇒ 'c) ⇒ 'x ⇒ 'y"
where "map_val f xs = oalist_of_listy (map_val_raw f (list_of_oalistx xs))"
definition map2_val :: "('a ⇒ 'b ⇒ 'c ⇒ 'd) ⇒ 'x ⇒ 'y ⇒ 'z"
where "map2_val f xs ys =
oalist_of_listz (map2_val_raw f (map_val_raw (λk b. f k b 0)) (map_val_raw (λk. f k 0))
(list_of_oalistx xs) (list_of_oalisty ys))"
definition map2_val_rneutr :: "('a ⇒ 'b ⇒ 'c ⇒ 'b) ⇒ 'x ⇒ 'y ⇒ 'x"
where "map2_val_rneutr f xs ys =
oalist_of_listx (map2_val_raw f id (map_val_raw (λk. f k 0)) (list_of_oalistx xs) (list_of_oalisty ys))"
definition lex_ord :: "'o ⇒ ('a ⇒ ('b, 'c) comp_opt) ⇒ ('x, 'y) comp_opt"
where "lex_ord ko f xs ys = lex_ord_raw ko f (list_of_oalistx xs) (list_of_oalisty ys)"
definition prod_ord :: "('a ⇒ 'b ⇒ 'c ⇒ bool) ⇒ 'x ⇒ 'y ⇒ bool"
where "prod_ord f xs ys = prod_ord_raw f (list_of_oalistx xs) (list_of_oalisty ys)"
subsubsection ‹@{const map_val}›
lemma map_val_cong:
assumes "⋀k v. (k, v) ∈ set (fst (list_of_oalistx xs)) ⟹ f k v = g k v"
shows "map_val f xs = map_val g xs"
unfolding map_val_def by (rule arg_cong[where f=oalist_of_listy], rule map_val_raw_cong, elim assms)
lemma list_of_oalist_map_val [simp, code abstract]:
"list_of_oalisty (map_val f xs) = map_val_raw f (list_of_oalistx xs)"
unfolding map_val_def
by (rule oay.list_of_oalist_of_list_id, rule oalist_inv_map_val_raw, fact oalist_inv_list_of_oalist)
lemma lookup_map_val: "f k 0 = 0 ⟹ oay.lookup (map_val f xs) k = f k (lookup xs k)"
by (simp add: oay.lookup_def lookup_def lookup_raw_map_val_raw oalist_inv_list_of_oalist)
subsubsection ‹@{const map2_val} and @{const map2_val_rneutr}›
lemma list_of_oalist_map2_val [simp, code abstract]:
"list_of_oalistz (map2_val f xs ys) =
map2_val_raw f (map_val_raw (λk b. f k b 0)) (map_val_raw (λk. f k 0)) (list_of_oalistx xs) (list_of_oalisty ys)"
unfolding map2_val_def
by (rule oaz.list_of_oalist_of_list_id, rule oalist_inv_map2_val_raw,
fact oalist_inv_list_of_oalist, fact oay.oalist_inv_list_of_oalist,
fact map2_val_compat'_map_val_raw, fact map2_val_compat'_map_val_raw)
lemma list_of_oalist_map2_val_rneutr [simp, code abstract]:
"list_of_oalistx (map2_val_rneutr f xs ys) =
map2_val_raw f id (map_val_raw (λk c. f k 0 c)) (list_of_oalistx xs) (list_of_oalisty ys)"
unfolding map2_val_rneutr_def
by (rule list_of_oalist_of_list_id, rule oalist_inv_map2_val_raw,
fact oalist_inv_list_of_oalist, fact oay.oalist_inv_list_of_oalist,
fact map2_val_compat'_id, fact map2_val_compat'_map_val_raw)
lemma lookup_map2_val:
assumes "⋀k. f k 0 0 = 0"
shows "oaz.lookup (map2_val f xs ys) k = f k (lookup xs k) (oay.lookup ys k)"
by (simp add: oaz.lookup_def oay.lookup_def lookup_def lookup_raw_map2_val_raw
map2_val_compat'_map_val_raw assms oalist_inv_list_of_oalist oay.oalist_inv_list_of_oalist)
lemma lookup_map2_val_rneutr:
assumes "⋀k x. f k x 0 = x"
shows "lookup (map2_val_rneutr f xs ys) k = f k (lookup xs k) (oay.lookup ys k)"
proof (simp add: lookup_def oay.lookup_def, rule lookup_raw_map2_val_raw)
fix zs::"('a, 'b, 'o) oalist_raw"
assume "oalist_inv zs"
thus "id zs = map_val_raw (λk v. f k v 0) zs" by (simp add: assms map_raw_id)
qed (fact oalist_inv_list_of_oalist, fact oay.oalist_inv_list_of_oalist,
fact map2_val_compat'_id, fact map2_val_compat'_map_val_raw, rule refl, simp only: assms)
lemma map2_val_rneutr_singleton_eq_update_by_fun:
assumes "⋀a x. f a x 0 = x" and "list_of_oalisty ys = ([(k, v)], oy)"
shows "map2_val_rneutr f xs ys = update_by_fun k (λx. f k x v) xs"
by (simp add: map2_val_rneutr_def update_by_fun_def assms map2_val_raw_singleton_eq_update_by_fun_raw oalist_inv_list_of_oalist)
subsubsection ‹@{const lex_ord} and @{const prod_ord}›
lemma lex_ord_EqI:
"(⋀k. k ∈ fst ` set (fst (list_of_oalistx xs)) ∪ fst ` set (fst (list_of_oalisty ys)) ⟹
f k (lookup xs k) (oay.lookup ys k) = Some Eq) ⟹
lex_ord ko f xs ys = Some Eq"
by (simp add: lex_ord_def lookup_def oay.lookup_def, rule lex_ord_raw_EqI,
rule oalist_inv_list_of_oalist, rule oay.oalist_inv_list_of_oalist, blast)
lemma lex_ord_valI:
assumes "aux ≠ Some Eq" and "k ∈ fst ` set (fst (list_of_oalistx xs)) ∪ fst ` set (fst (list_of_oalisty ys))"
shows "aux = f k (lookup xs k) (oay.lookup ys k) ⟹
(⋀k'. k' ∈ fst ` set (fst (list_of_oalistx xs)) ∪ fst ` set (fst (list_of_oalisty ys)) ⟹
lt ko k' k ⟹ f k' (lookup xs k') (oay.lookup ys k') = Some Eq) ⟹
lex_ord ko f xs ys = aux"
by (simp (no_asm_use) add: lex_ord_def lookup_def oay.lookup_def, rule lex_ord_raw_valI,
rule oalist_inv_list_of_oalist, rule oay.oalist_inv_list_of_oalist, rule assms(1), rule assms(2), blast+)
lemma lex_ord_EqD:
"lex_ord ko f xs ys = Some Eq ⟹
k ∈ fst ` set (fst (list_of_oalistx xs)) ∪ fst ` set (fst (list_of_oalisty ys)) ⟹
f k (lookup xs k) (oay.lookup ys k) = Some Eq"
by (simp add: lex_ord_def lookup_def oay.lookup_def, rule lex_ord_raw_EqD[where f=f],
rule oalist_inv_list_of_oalist, rule oay.oalist_inv_list_of_oalist, assumption, simp)
lemma lex_ord_valE:
assumes "lex_ord ko f xs ys = aux" and "aux ≠ Some Eq"
obtains k where "k ∈ fst ` set (fst (list_of_oalistx xs)) ∪ fst ` set (fst (list_of_oalisty ys))"
and "aux = f k (lookup xs k) (oay.lookup ys k)"
and "⋀k'. k' ∈ fst ` set (fst (list_of_oalistx xs)) ∪ fst ` set (fst (list_of_oalisty ys)) ⟹
lt ko k' k ⟹ f k' (lookup xs k') (oay.lookup ys k') = Some Eq"
proof -
note oalist_inv_list_of_oalist oay.oalist_inv_list_of_oalist
moreover from assms(1) have "lex_ord_raw ko f (list_of_oalistx xs) (list_of_oalisty ys) = aux"
by (simp only: lex_ord_def)
ultimately obtain k where 1: "k ∈ fst ` set (fst (list_of_oalistx xs)) ∪ fst ` set (fst (list_of_oalisty ys))"
and "aux = f k (lookup_raw (list_of_oalistx xs) k) (lookup_raw (list_of_oalisty ys) k)"
and "⋀k'. k' ∈ fst ` set (fst (list_of_oalistx xs)) ∪ fst ` set (fst (list_of_oalisty ys)) ⟹
lt ko k' k ⟹
f k' (lookup_raw (list_of_oalistx xs) k') (lookup_raw (list_of_oalisty ys) k') = Some Eq"
using assms(2) by (rule lex_ord_raw_valE, blast)
from this(2, 3) have "aux = f k (lookup xs k) (oay.lookup ys k)"
and "⋀k'. k' ∈ fst ` set (fst (list_of_oalistx xs)) ∪ fst ` set (fst (list_of_oalisty ys)) ⟹
lt ko k' k ⟹ f k' (lookup xs k') (oay.lookup ys k') = Some Eq"
by (simp_all only: lookup_def oay.lookup_def)
with 1 show ?thesis ..
qed
lemma prod_ord_alt:
"prod_ord P xs ys ⟷
(∀k∈fst ` set (fst (list_of_oalistx xs)) ∪ fst ` set (fst (list_of_oalisty ys)).
P k (lookup xs k) (oay.lookup ys k))"
by (simp add: prod_ord_def lookup_def oay.lookup_def prod_ord_raw_alt oalist_inv_list_of_oalist oay.oalist_inv_list_of_oalist)
end
subsection ‹Type ‹oalist››
global_interpretation ko: comparator "key_compare ko"
defines lookup_pair_ko = ko.lookup_pair
and update_by_pair_ko = ko.update_by_pair
and update_by_fun_pair_ko = ko.update_by_fun_pair
and update_by_fun_gr_pair_ko = ko.update_by_fun_gr_pair
and map2_val_pair_ko = ko.map2_val_pair
and lex_ord_pair_ko = ko.lex_ord_pair
and prod_ord_pair_ko = ko.prod_ord_pair
and sort_oalist_ko' = ko.sort_oalist
by (fact comparator_key_compare)
lemma ko_le: "ko.le = le_of_key_order"
by (intro ext, simp add: le_of_comp_def le_of_key_order_alt split: order.split)
global_interpretation ko: oalist_raw "λx. x"
rewrites "comparator.lookup_pair (key_compare ko) = lookup_pair_ko ko"
and "comparator.update_by_pair (key_compare ko) = update_by_pair_ko ko"
and "comparator.update_by_fun_pair (key_compare ko) = update_by_fun_pair_ko ko"
and "comparator.update_by_fun_gr_pair (key_compare ko) = update_by_fun_gr_pair_ko ko"
and "comparator.map2_val_pair (key_compare ko) = map2_val_pair_ko ko"
and "comparator.lex_ord_pair (key_compare ko) = lex_ord_pair_ko ko"
and "comparator.prod_ord_pair (key_compare ko) = prod_ord_pair_ko ko"
and "comparator.sort_oalist (key_compare ko) = sort_oalist_ko' ko"
defines sort_oalist_aux_ko = ko.sort_oalist_aux
and lookup_ko = ko.lookup_raw
and sorted_domain_ko = ko.sorted_domain_raw
and tl_ko = ko.tl_raw
and min_key_val_ko = ko.min_key_val_raw
and update_by_ko = ko.update_by_raw
and update_by_fun_ko = ko.update_by_fun_raw
and update_by_fun_gr_ko = ko.update_by_fun_gr_raw
and map2_val_ko = ko.map2_val_raw
and lex_ord_ko = ko.lex_ord_raw
and prod_ord_ko = ko.prod_ord_raw
and oalist_eq_ko = ko.oalist_eq_raw
and sort_oalist_ko = ko.sort_oalist_raw
subgoal by (simp only: lookup_pair_ko_def)
subgoal by (simp only: update_by_pair_ko_def)
subgoal by (simp only: update_by_fun_pair_ko_def)
subgoal by (simp only: update_by_fun_gr_pair_ko_def)
subgoal by (simp only: map2_val_pair_ko_def)
subgoal by (simp only: lex_ord_pair_ko_def)
subgoal by (simp only: prod_ord_pair_ko_def)
subgoal by (simp only: sort_oalist_ko'_def)
done
typedef (overloaded) ('a, 'b) oalist = "{xs::('a, 'b::zero, 'a key_order) oalist_raw. ko.oalist_inv xs}"
morphisms list_of_oalist Abs_oalist
by (auto simp: ko.oalist_inv_def intro: ko.oalist_inv_raw_Nil)
lemma oalist_eq_iff: "xs = ys ⟷ list_of_oalist xs = list_of_oalist ys"
by (simp add: list_of_oalist_inject)
lemma oalist_eqI: "list_of_oalist xs = list_of_oalist ys ⟹ xs = ys"
by (simp add: oalist_eq_iff)
text ‹Formal, totalized constructor for @{typ "('a, 'b) oalist"}:›
definition OAlist :: "('a × 'b) list × 'a key_order ⇒ ('a, 'b::zero) oalist" where
"OAlist xs = Abs_oalist (sort_oalist_ko xs)"
definition "oalist_of_list = OAlist"
lemma oalist_inv_list_of_oalist: "ko.oalist_inv (list_of_oalist xs)"
using list_of_oalist [of xs] by simp
lemma list_of_oalist_OAlist: "list_of_oalist (OAlist xs) = sort_oalist_ko xs"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
show ?thesis by (simp add: xs OAlist_def Abs_oalist_inverse ko.oalist_inv_raw_sort_oalist ko.oalist_inv_alt)
qed
lemma OAlist_list_of_oalist [code abstype]: "OAlist (list_of_oalist xs) = xs"
proof -
obtain xs' ox where xs: "list_of_oalist xs = (xs', ox)" by fastforce
have "ko.oalist_inv_raw ox xs'" by (simp add: xs[symmetric] ko.oalist_inv_alt[symmetric] oalist_inv_list_of_oalist)
thus ?thesis by (simp add: xs OAlist_def ko.sort_oalist_id, simp add: list_of_oalist_inverse xs[symmetric])
qed
lemma [code abstract]: "list_of_oalist (oalist_of_list xs) = sort_oalist_ko xs"
by (simp add: list_of_oalist_OAlist oalist_of_list_def)
global_interpretation oa: oalist_abstract "λx. x" list_of_oalist OAlist
defines OAlist_lookup = oa.lookup
and OAlist_sorted_domain = oa.sorted_domain
and OAlist_empty = oa.empty
and OAlist_reorder = oa.reorder
and OAlist_tl = oa.tl
and OAlist_hd = oa.hd
and OAlist_except_min = oa.except_min
and OAlist_min_key_val = oa.min_key_val
and OAlist_insert = oa.insert
and OAlist_update_by_fun = oa.update_by_fun
and OAlist_update_by_fun_gr = oa.update_by_fun_gr
and OAlist_filter = oa.filter
and OAlist_map2_val_neutr = oa.map2_val_neutr
and OAlist_eq = oa.oalist_eq
apply standard
subgoal by (fact oalist_inv_list_of_oalist)
subgoal by (simp only: list_of_oalist_OAlist sort_oalist_ko_def)
subgoal by (fact OAlist_list_of_oalist)
done
global_interpretation oa: oalist_abstract3 "λx. x"
"list_of_oalist::('a, 'b) oalist ⇒ ('a, 'b::zero, 'a key_order) oalist_raw" OAlist
"list_of_oalist::('a, 'c) oalist ⇒ ('a, 'c::zero, 'a key_order) oalist_raw" OAlist
"list_of_oalist::('a, 'd) oalist ⇒ ('a, 'd::zero, 'a key_order) oalist_raw" OAlist
defines OAlist_map_val = oa.map_val
and OAlist_map2_val = oa.map2_val
and OAlist_map2_val_rneutr = oa.map2_val_rneutr
and OAlist_lex_ord = oa.lex_ord
and OAlist_prod_ord = oa.prod_ord ..
lemmas OAlist_lookup_single = oa.lookup_oalist_of_list_single[folded oalist_of_list_def]
subsection ‹Type ‹oalist_tc››
text ‹``tc'' stands for ``type class''.›
global_interpretation tc: comparator "comparator_of"
defines lookup_pair_tc = tc.lookup_pair
and update_by_pair_tc = tc.update_by_pair
and update_by_fun_pair_tc = tc.update_by_fun_pair
and update_by_fun_gr_pair_tc = tc.update_by_fun_gr_pair
and map2_val_pair_tc = tc.map2_val_pair
and lex_ord_pair_tc = tc.lex_ord_pair
and prod_ord_pair_tc = tc.prod_ord_pair
and sort_oalist_tc = tc.sort_oalist
by (fact comparator_of)
lemma tc_le_lt [simp]: "tc.le = (≤)" "tc.lt = (<)"
by (auto simp: le_of_comp_def lt_of_comp_def comparator_of_def intro!: ext split: order.split_asm if_split_asm)
typedef (overloaded) ('a, 'b) oalist_tc = "{xs::('a::linorder × 'b::zero) list. tc.oalist_inv_raw xs}"
morphisms list_of_oalist_tc Abs_oalist_tc
by (auto intro: tc.oalist_inv_raw_Nil)
lemma oalist_tc_eq_iff: "xs = ys ⟷ list_of_oalist_tc xs = list_of_oalist_tc ys"
by (simp add: list_of_oalist_tc_inject)
lemma oalist_tc_eqI: "list_of_oalist_tc xs = list_of_oalist_tc ys ⟹ xs = ys"
by (simp add: oalist_tc_eq_iff)
text ‹Formal, totalized constructor for @{typ "('a, 'b) oalist_tc"}:›
definition OAlist_tc :: "('a × 'b) list ⇒ ('a::linorder, 'b::zero) oalist_tc" where
"OAlist_tc xs = Abs_oalist_tc (sort_oalist_tc xs)"
definition "oalist_tc_of_list = OAlist_tc"
lemma oalist_inv_list_of_oalist_tc: "tc.oalist_inv_raw (list_of_oalist_tc xs)"
using list_of_oalist_tc[of xs] by simp
lemma list_of_oalist_OAlist_tc: "list_of_oalist_tc (OAlist_tc xs) = sort_oalist_tc xs"
by (simp add: OAlist_tc_def Abs_oalist_tc_inverse tc.oalist_inv_raw_sort_oalist)
lemma OAlist_list_of_oalist_tc [code abstype]: "OAlist_tc (list_of_oalist_tc xs) = xs"
by (simp add: OAlist_tc_def tc.sort_oalist_id list_of_oalist_tc_inverse oalist_inv_list_of_oalist_tc)
lemma list_of_oalist_tc_of_list [code abstract]: "list_of_oalist_tc (oalist_tc_of_list xs) = sort_oalist_tc xs"
by (simp add: list_of_oalist_OAlist_tc oalist_tc_of_list_def)
lemma list_of_oalist_tc_of_list_id:
assumes "tc.oalist_inv_raw xs"
shows "list_of_oalist_tc (OAlist_tc xs) = xs"
using assms by (simp add: list_of_oalist_OAlist_tc tc.sort_oalist_id)
text ‹It is better to define the following operations directly instead of interpreting
@{locale oalist_abstract}, because @{locale oalist_abstract} defines the operations via their
‹_raw› analogues, whereas in this case we can define them directly via their ‹_pair› analogues.›
definition OAlist_tc_lookup :: "('a::linorder, 'b::zero) oalist_tc ⇒ 'a ⇒ 'b"
where "OAlist_tc_lookup xs = lookup_pair_tc (list_of_oalist_tc xs)"
definition OAlist_tc_sorted_domain :: "('a::linorder, 'b::zero) oalist_tc ⇒ 'a list"
where "OAlist_tc_sorted_domain xs = map fst (list_of_oalist_tc xs)"
definition OAlist_tc_empty :: "('a::linorder, 'b::zero) oalist_tc"
where "OAlist_tc_empty = OAlist_tc []"
definition OAlist_tc_except_min :: "('a, 'b) oalist_tc ⇒ ('a::linorder, 'b::zero) oalist_tc"
where "OAlist_tc_except_min xs = OAlist_tc (tl (list_of_oalist_tc xs))"
definition OAlist_tc_min_key_val :: "('a::linorder, 'b::zero) oalist_tc ⇒ ('a × 'b)"
where "OAlist_tc_min_key_val xs = hd (list_of_oalist_tc xs)"
definition OAlist_tc_insert :: "('a × 'b) ⇒ ('a, 'b) oalist_tc ⇒ ('a::linorder, 'b::zero) oalist_tc"
where "OAlist_tc_insert x xs = OAlist_tc (update_by_pair_tc x (list_of_oalist_tc xs))"
definition OAlist_tc_update_by_fun :: "'a ⇒ ('b ⇒ 'b) ⇒ ('a, 'b) oalist_tc ⇒ ('a::linorder, 'b::zero) oalist_tc"
where "OAlist_tc_update_by_fun k f xs = OAlist_tc (update_by_fun_pair_tc k f (list_of_oalist_tc xs))"
definition OAlist_tc_update_by_fun_gr :: "'a ⇒ ('b ⇒ 'b) ⇒ ('a, 'b) oalist_tc ⇒ ('a::linorder, 'b::zero) oalist_tc"
where "OAlist_tc_update_by_fun_gr k f xs = OAlist_tc (update_by_fun_gr_pair_tc k f (list_of_oalist_tc xs))"
definition OAlist_tc_filter :: "(('a × 'b) ⇒ bool) ⇒ ('a, 'b) oalist_tc ⇒ ('a::linorder, 'b::zero) oalist_tc"
where "OAlist_tc_filter P xs = OAlist_tc (filter P (list_of_oalist_tc xs))"
definition OAlist_tc_map_val :: "('a ⇒ 'b ⇒ 'c) ⇒ ('a, 'b::zero) oalist_tc ⇒ ('a::linorder, 'c::zero) oalist_tc"
where "OAlist_tc_map_val f xs = OAlist_tc (map_val_pair f (list_of_oalist_tc xs))"
definition OAlist_tc_map2_val :: "('a ⇒ 'b ⇒ 'c ⇒ 'd) ⇒ ('a, 'b::zero) oalist_tc ⇒ ('a, 'c::zero) oalist_tc ⇒
('a::linorder, 'd::zero) oalist_tc"
where "OAlist_tc_map2_val f xs ys =
OAlist_tc (map2_val_pair_tc f (map_val_pair (λk b. f k b 0)) (map_val_pair (λk. f k 0))
(list_of_oalist_tc xs) (list_of_oalist_tc ys))"
definition OAlist_tc_map2_val_rneutr :: "('a ⇒ 'b ⇒ 'c ⇒ 'b) ⇒ ('a, 'b) oalist_tc ⇒ ('a, 'c::zero) oalist_tc ⇒
('a::linorder, 'b::zero) oalist_tc"
where "OAlist_tc_map2_val_rneutr f xs ys =
OAlist_tc (map2_val_pair_tc f id (map_val_pair (λk. f k 0)) (list_of_oalist_tc xs) (list_of_oalist_tc ys))"
definition OAlist_tc_map2_val_neutr :: "('a ⇒ 'b ⇒ 'b ⇒ 'b) ⇒ ('a, 'b) oalist_tc ⇒
('a, 'b) oalist_tc ⇒ ('a::linorder, 'b::zero) oalist_tc"
where "OAlist_tc_map2_val_neutr f xs ys = OAlist_tc (map2_val_pair_tc f id id (list_of_oalist_tc xs) (list_of_oalist_tc ys))"
definition OAlist_tc_lex_ord :: "('a ⇒ ('b, 'c) comp_opt) ⇒ (('a, 'b::zero) oalist_tc, ('a::linorder, 'c::zero) oalist_tc) comp_opt"
where "OAlist_tc_lex_ord f xs ys = lex_ord_pair_tc f (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
definition OAlist_tc_prod_ord :: "('a ⇒ 'b ⇒ 'c ⇒ bool) ⇒ ('a, 'b::zero) oalist_tc ⇒ ('a::linorder, 'c::zero) oalist_tc ⇒ bool"
where "OAlist_tc_prod_ord f xs ys = prod_ord_pair_tc f (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
subsubsection ‹@{const OAlist_tc_lookup}›
lemma OAlist_tc_lookup_eq_valueI: "(k, v) ∈ set (list_of_oalist_tc xs) ⟹ OAlist_tc_lookup xs k = v"
unfolding OAlist_tc_lookup_def using oalist_inv_list_of_oalist_tc by (rule tc.lookup_pair_eq_valueI)
lemma OAlist_tc_lookup_inj: "OAlist_tc_lookup xs = OAlist_tc_lookup ys ⟹ xs = ys"
by (simp add: OAlist_tc_lookup_def oalist_inv_list_of_oalist_tc oalist_tc_eqI tc.lookup_pair_inj)
lemma OAlist_tc_lookup_oalist_of_list:
"distinct (map fst xs) ⟹ OAlist_tc_lookup (oalist_tc_of_list xs) = lookup_dflt xs"
by (simp add: OAlist_tc_lookup_def list_of_oalist_tc_of_list tc.lookup_pair_sort_oalist')
subsubsection ‹@{const OAlist_tc_sorted_domain}›
lemma set_OAlist_tc_sorted_domain: "set (OAlist_tc_sorted_domain xs) = fst ` set (list_of_oalist_tc xs)"
unfolding OAlist_tc_sorted_domain_def by simp
lemma in_OAlist_tc_sorted_domain_iff_lookup: "k ∈ set (OAlist_tc_sorted_domain xs) ⟷ (OAlist_tc_lookup xs k ≠ 0)"
unfolding OAlist_tc_sorted_domain_def OAlist_tc_lookup_def using oalist_inv_list_of_oalist_tc tc.lookup_pair_eq_0
by fastforce
lemma sorted_OAlist_tc_sorted_domain: "sorted_wrt (<) (OAlist_tc_sorted_domain xs)"
unfolding OAlist_tc_sorted_domain_def tc_le_lt[symmetric] using oalist_inv_list_of_oalist_tc
by (rule tc.oalist_inv_rawD2)
subsubsection ‹@{const OAlist_tc_empty} and Singletons›
lemma list_of_oalist_OAlist_tc_empty [simp, code abstract]: "list_of_oalist_tc OAlist_tc_empty = []"
unfolding OAlist_tc_empty_def using tc.oalist_inv_raw_Nil by (rule list_of_oalist_tc_of_list_id)
lemma lookup_OAlist_tc_empty: "OAlist_tc_lookup OAlist_tc_empty k = 0"
by (simp add: OAlist_tc_lookup_def)
lemma OAlist_tc_lookup_single:
"OAlist_tc_lookup (oalist_tc_of_list [(k, v)]) k' = (if k = k' then v else 0)"
by (simp add: OAlist_tc_lookup_def list_of_oalist_tc_of_list tc.sort_oalist_def comparator_of_def split: order.split)
subsubsection ‹@{const OAlist_tc_except_min}›
lemma list_of_oalist_OAlist_tc_except_min [simp, code abstract]:
"list_of_oalist_tc (OAlist_tc_except_min xs) = tl (list_of_oalist_tc xs)"
unfolding OAlist_tc_except_min_def
by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_tl, fact oalist_inv_list_of_oalist_tc)
lemma lookup_OAlist_tc_except_min:
"OAlist_tc_lookup (OAlist_tc_except_min xs) k =
(if (∀k'∈fst ` set (list_of_oalist_tc xs). k ≤ k') then 0 else OAlist_tc_lookup xs k)"
by (simp add: OAlist_tc_lookup_def tc.lookup_pair_tl oalist_inv_list_of_oalist_tc split del: if_split cong: if_cong)
subsubsection ‹@{const OAlist_tc_min_key_val}›
lemma OAlist_tc_min_key_val_in:
assumes "list_of_oalist_tc xs ≠ []"
shows "OAlist_tc_min_key_val xs ∈ set (list_of_oalist_tc xs)"
unfolding OAlist_tc_min_key_val_def using assms by simp
lemma snd_OAlist_tc_min_key_val:
assumes "list_of_oalist_tc xs ≠ []"
shows "snd (OAlist_tc_min_key_val xs) = OAlist_tc_lookup xs (fst (OAlist_tc_min_key_val xs))"
proof -
let ?xs = "list_of_oalist_tc xs"
from assms have *: "OAlist_tc_min_key_val xs ∈ set ?xs" by (rule OAlist_tc_min_key_val_in)
show ?thesis unfolding OAlist_tc_lookup_def
by (rule HOL.sym, rule tc.lookup_pair_eq_valueI, fact oalist_inv_list_of_oalist_tc, simp add: *)
qed
lemma OAlist_tc_min_key_val_minimal:
assumes "z ∈ set (list_of_oalist_tc xs)"
shows "fst (OAlist_tc_min_key_val xs) ≤ fst z"
proof -
let ?xs = "list_of_oalist_tc xs"
from assms have "?xs ≠ []" by auto
hence "OAlist_tc_sorted_domain xs ≠ []" by (simp add: OAlist_tc_sorted_domain_def)
then obtain h xs' where eq: "OAlist_tc_sorted_domain xs = h # xs'" using list.exhaust by blast
with sorted_OAlist_tc_sorted_domain[of xs] have *: "∀y∈set xs'. h < y" by simp
from assms have "fst z ∈ set (OAlist_tc_sorted_domain xs)" by (simp add: OAlist_tc_sorted_domain_def)
hence disj: "fst z = h ∨ fst z ∈ set xs'" by (simp add: eq)
from ‹?xs ≠ []› have "fst (OAlist_tc_min_key_val xs) = hd (OAlist_tc_sorted_domain xs)"
by (simp add: OAlist_tc_min_key_val_def OAlist_tc_sorted_domain_def hd_map)
also have "... = h" by (simp add: eq)
also from disj have "... ≤ fst z"
proof
assume "fst z = h"
thus ?thesis by simp
next
assume "fst z ∈ set xs'"
with * have "h < fst z" ..
thus ?thesis by simp
qed
finally show ?thesis .
qed
subsubsection ‹@{const OAlist_tc_insert}›
lemma list_of_oalist_OAlist_tc_insert [simp, code abstract]:
"list_of_oalist_tc (OAlist_tc_insert x xs) = update_by_pair_tc x (list_of_oalist_tc xs)"
unfolding OAlist_tc_insert_def
by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_update_by_pair, fact oalist_inv_list_of_oalist_tc)
lemma lookup_OAlist_tc_insert: "OAlist_tc_lookup (OAlist_tc_insert (k, v) xs) k' = (if k = k' then v else OAlist_tc_lookup xs k')"
by (simp add: OAlist_tc_lookup_def tc.lookup_pair_update_by_pair oalist_inv_list_of_oalist_tc split del: if_split cong: if_cong)
subsubsection ‹@{const OAlist_tc_update_by_fun} and @{const OAlist_tc_update_by_fun_gr}›
lemma list_of_oalist_OAlist_tc_update_by_fun [simp, code abstract]:
"list_of_oalist_tc (OAlist_tc_update_by_fun k f xs) = update_by_fun_pair_tc k f (list_of_oalist_tc xs)"
unfolding OAlist_tc_update_by_fun_def
by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_update_by_fun_pair, fact oalist_inv_list_of_oalist_tc)
lemma lookup_OAlist_tc_update_by_fun:
"OAlist_tc_lookup (OAlist_tc_update_by_fun k f xs) k' = (if k = k' then f else id) (OAlist_tc_lookup xs k')"
by (simp add: OAlist_tc_lookup_def tc.lookup_pair_update_by_fun_pair oalist_inv_list_of_oalist_tc split del: if_split cong: if_cong)
lemma list_of_oalist_OAlist_tc_update_by_fun_gr [simp, code abstract]:
"list_of_oalist_tc (OAlist_tc_update_by_fun_gr k f xs) = update_by_fun_gr_pair_tc k f (list_of_oalist_tc xs)"
unfolding OAlist_tc_update_by_fun_gr_def
by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_update_by_fun_gr_pair, fact oalist_inv_list_of_oalist_tc)
lemma OAlist_tc_update_by_fun_gr_eq_OAlist_tc_update_by_fun: "OAlist_tc_update_by_fun_gr = OAlist_tc_update_by_fun"
by (rule, rule, rule,
simp add: OAlist_tc_update_by_fun_gr_def OAlist_tc_update_by_fun_def
tc.update_by_fun_gr_pair_eq_update_by_fun_pair oalist_inv_list_of_oalist_tc)
subsubsection ‹@{const OAlist_tc_filter}›
lemma list_of_oalist_OAlist_tc_filter [simp, code abstract]:
"list_of_oalist_tc (OAlist_tc_filter P xs) = filter P (list_of_oalist_tc xs)"
unfolding OAlist_tc_filter_def
by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_filter, fact oalist_inv_list_of_oalist_tc)
lemma lookup_OAlist_tc_filter: "OAlist_tc_lookup (OAlist_tc_filter P xs) k = (let v = OAlist_tc_lookup xs k in if P (k, v) then v else 0)"
by (simp add: OAlist_tc_lookup_def tc.lookup_pair_filter oalist_inv_list_of_oalist_tc)
subsubsection ‹@{const OAlist_tc_map_val}›
lemma list_of_oalist_OAlist_tc_map_val [simp, code abstract]:
"list_of_oalist_tc (OAlist_tc_map_val f xs) = map_val_pair f (list_of_oalist_tc xs)"
unfolding OAlist_tc_map_val_def
by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map_val_pair, fact oalist_inv_list_of_oalist_tc)
lemma OAlist_tc_map_val_cong:
assumes "⋀k v. (k, v) ∈ set (list_of_oalist_tc xs) ⟹ f k v = g k v"
shows "OAlist_tc_map_val f xs = OAlist_tc_map_val g xs"
unfolding OAlist_tc_map_val_def by (rule arg_cong[where f=OAlist_tc], rule tc.map_val_pair_cong, elim assms)
lemma lookup_OAlist_tc_map_val: "f k 0 = 0 ⟹ OAlist_tc_lookup (OAlist_tc_map_val f xs) k = f k (OAlist_tc_lookup xs k)"
by (simp add: OAlist_tc_lookup_def tc.lookup_pair_map_val_pair oalist_inv_list_of_oalist_tc)
subsubsection ‹@{const OAlist_tc_map2_val} @{const OAlist_tc_map2_val_rneutr} and @{const OAlist_tc_map2_val_neutr}›
lemma list_of_oalist_map2_val [simp, code abstract]:
"list_of_oalist_tc (OAlist_tc_map2_val f xs ys) =
map2_val_pair_tc f (map_val_pair (λk b. f k b 0)) (map_val_pair (λk. f k 0)) (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
unfolding OAlist_tc_map2_val_def
by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map2_val_pair,
fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
fact tc.map2_val_compat_map_val_pair, fact tc.map2_val_compat_map_val_pair)
lemma list_of_oalist_OAlist_tc_map2_val_rneutr [simp, code abstract]:
"list_of_oalist_tc (OAlist_tc_map2_val_rneutr f xs ys) =
map2_val_pair_tc f id (map_val_pair (λk c. f k 0 c)) (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
unfolding OAlist_tc_map2_val_rneutr_def
by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map2_val_pair,
fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
fact tc.map2_val_compat_id, fact tc.map2_val_compat_map_val_pair)
lemma list_of_oalist_OAlist_tc_map2_val_neutr [simp, code abstract]:
"list_of_oalist_tc (OAlist_tc_map2_val_neutr f xs ys) = map2_val_pair_tc f id id (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
unfolding OAlist_tc_map2_val_neutr_def
by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map2_val_pair,
fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
fact tc.map2_val_compat_id, fact tc.map2_val_compat_id)
lemma lookup_OAlist_tc_map2_val:
assumes "⋀k. f k 0 0 = 0"
shows "OAlist_tc_lookup (OAlist_tc_map2_val f xs ys) k = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
by (simp add: OAlist_tc_lookup_def tc.lookup_pair_map2_val_pair
tc.map2_val_compat_map_val_pair assms oalist_inv_list_of_oalist_tc)
lemma lookup_OAlist_tc_map2_val_rneutr:
assumes "⋀k x. f k x 0 = x"
shows "OAlist_tc_lookup (OAlist_tc_map2_val_rneutr f xs ys) k = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
proof (simp add: OAlist_tc_lookup_def, rule tc.lookup_pair_map2_val_pair)
fix zs::"('a × 'b) list"
assume "tc.oalist_inv_raw zs"
thus "id zs = map_val_pair (λk v. f k v 0) zs" by (simp add: assms tc.map_pair_id)
qed (fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
fact tc.map2_val_compat_id, fact tc.map2_val_compat_map_val_pair, rule refl, simp only: assms)
lemma lookup_OAlist_tc_map2_val_neutr:
assumes "⋀k x. f k x 0 = x" and "⋀k x. f k 0 x = x"
shows "OAlist_tc_lookup (OAlist_tc_map2_val_neutr f xs ys) k = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
proof (simp add: OAlist_tc_lookup_def, rule tc.lookup_pair_map2_val_pair)
fix zs::"('a × 'b) list"
assume "tc.oalist_inv_raw zs"
thus "id zs = map_val_pair (λk v. f k v 0) zs" by (simp add: assms(1) tc.map_pair_id)
next
fix zs::"('a × 'b) list"
assume "tc.oalist_inv_raw zs"
thus "id zs = map_val_pair (λk. f k 0) zs" by (simp add: assms(2) tc.map_pair_id)
qed (fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
fact tc.map2_val_compat_id, fact tc.map2_val_compat_id, simp only: assms(1))
lemma OAlist_tc_map2_val_rneutr_singleton_eq_OAlist_tc_update_by_fun:
assumes "⋀a x. f a x 0 = x" and "list_of_oalist_tc ys = [(k, v)]"
shows "OAlist_tc_map2_val_rneutr f xs ys = OAlist_tc_update_by_fun k (λx. f k x v) xs"
by (simp add: OAlist_tc_map2_val_rneutr_def OAlist_tc_update_by_fun_def assms
tc.map2_val_pair_singleton_eq_update_by_fun_pair oalist_inv_list_of_oalist_tc)
subsubsection ‹@{const OAlist_tc_lex_ord} and @{const OAlist_tc_prod_ord}›
lemma OAlist_tc_lex_ord_EqI:
"(⋀k. k ∈ fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys) ⟹
f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k) = Some Eq) ⟹
OAlist_tc_lex_ord f xs ys = Some Eq"
by (simp add: OAlist_tc_lex_ord_def OAlist_tc_lookup_def, rule tc.lex_ord_pair_EqI,
rule oalist_inv_list_of_oalist_tc, rule oalist_inv_list_of_oalist_tc, blast)
lemma OAlist_tc_lex_ord_valI:
assumes "aux ≠ Some Eq" and "k ∈ fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys)"
shows "aux = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k) ⟹
(⋀k'. k' ∈ fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys) ⟹
k' < k ⟹ f k' (OAlist_tc_lookup xs k') (OAlist_tc_lookup ys k') = Some Eq) ⟹
OAlist_tc_lex_ord f xs ys = aux"
by (simp (no_asm_use) add: OAlist_tc_lex_ord_def OAlist_tc_lookup_def, rule tc.lex_ord_pair_valI,
rule oalist_inv_list_of_oalist_tc, rule oalist_inv_list_of_oalist_tc, rule assms(1), rule assms(2), simp_all)
lemma OAlist_tc_lex_ord_EqD:
"OAlist_tc_lex_ord f xs ys = Some Eq ⟹
k ∈ fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys) ⟹
f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k) = Some Eq"
by (simp add: OAlist_tc_lex_ord_def OAlist_tc_lookup_def, rule tc.lex_ord_pair_EqD[where f=f],
rule oalist_inv_list_of_oalist_tc, rule oalist_inv_list_of_oalist_tc, assumption, simp)
lemma OAlist_tc_lex_ord_valE:
assumes "OAlist_tc_lex_ord f xs ys = aux" and "aux ≠ Some Eq"
obtains k where "k ∈ fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys)"
and "aux = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
and "⋀k'. k' ∈ fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys) ⟹
k' < k ⟹ f k' (OAlist_tc_lookup xs k') (OAlist_tc_lookup ys k') = Some Eq"
proof -
note oalist_inv_list_of_oalist_tc oalist_inv_list_of_oalist_tc
moreover from assms(1) have "lex_ord_pair_tc f (list_of_oalist_tc xs) (list_of_oalist_tc ys) = aux"
by (simp only: OAlist_tc_lex_ord_def)
ultimately obtain k where 1: "k ∈ fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys)"
and "aux = f k (lookup_pair_tc (list_of_oalist_tc xs) k) (lookup_pair_tc (list_of_oalist_tc ys) k)"
and "⋀k'. k' ∈ fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys) ⟹
k' < k ⟹
f k' (lookup_pair_tc (list_of_oalist_tc xs) k') (lookup_pair_tc (list_of_oalist_tc ys) k') = Some Eq"
using assms(2) unfolding tc_le_lt[symmetric] by (rule tc.lex_ord_pair_valE, blast)
from this(2, 3) have "aux = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
and "⋀k'. k' ∈ fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys) ⟹
k' < k ⟹ f k' (OAlist_tc_lookup xs k') (OAlist_tc_lookup ys k') = Some Eq"
by (simp_all only: OAlist_tc_lookup_def)
with 1 show ?thesis ..
qed
lemma OAlist_tc_prod_ord_alt:
"OAlist_tc_prod_ord P xs ys ⟷
(∀k∈fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys).
P k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k))"
by (simp add: OAlist_tc_prod_ord_def OAlist_tc_lookup_def tc.prod_ord_pair_alt oalist_inv_list_of_oalist_tc)
subsubsection ‹Instance of @{class equal}›
instantiation oalist_tc :: (linorder, zero) equal
begin
definition equal_oalist_tc :: "('a, 'b) oalist_tc ⇒ ('a, 'b) oalist_tc ⇒ bool"
where "equal_oalist_tc xs ys = (list_of_oalist_tc xs = list_of_oalist_tc ys)"
instance by (intro_classes, simp add: equal_oalist_tc_def list_of_oalist_tc_inject)
end
subsection ‹Experiment›
lemma "oalist_tc_of_list [(0::nat, 4::nat), (1, 3), (0, 2), (1, 1)] = oalist_tc_of_list [(0, 4), (1, 3)]"
by eval
lemma "OAlist_tc_except_min (oalist_tc_of_list ([(1, 3), (0::nat, 4::nat), (0, 2), (1, 1)])) = oalist_tc_of_list [(1, 3)]"
by eval
lemma "OAlist_tc_min_key_val (oalist_tc_of_list [(1, 3), (0::nat, 4::nat), (0, 2), (1, 1)]) = (0, 4)"
by eval
lemma "OAlist_tc_lookup (oalist_tc_of_list [(0::nat, 4::nat), (1, 3), (0, 2), (1, 1)]) 1 = 3"
by eval
lemma "OAlist_tc_prod_ord (λ_. greater_eq)
(oalist_tc_of_list [(1, 4), (0::nat, 4::nat), (1, 3), (0, 2), (3, 1)])
(oalist_tc_of_list [(0, 4), (1, 3), (2, 2), (1, 1)]) = False"
by eval
lemma "OAlist_tc_map2_val_rneutr (λ_. minus)
(oalist_tc_of_list [(1, 4), (0::nat, 4::int), (1, 3), (0, 2), (3, 1)])
(oalist_tc_of_list [(0, 4), (1, 3), (2, 2), (1, 1)]) =
oalist_tc_of_list [(1, 1), (2, - 2), (3, 1)]"
by eval
end
Theory OAlist_Poly_Mapping
section ‹Ordered Associative Lists for Polynomials›
theory OAlist_Poly_Mapping
imports PP_Type MPoly_Type_Class_Ordered OAlist
begin
text ‹We introduce a dedicated type for ordered associative lists (oalists) representing polynomials.
To that end, we require the order relation the oalists are sorted wrt. to be admissible term orders,
and furthermore sort the lists @{emph ‹descending›} rather than @{emph ‹ascending›}, because this
allows to implement various operations more efficiently.
For technical reasons, we must restrict the type of terms to types embeddable into
@{typ "(nat, nat) pp × nat"}, though. All types we are interested in meet this requirement.›
lemma comparator_lexicographic:
fixes f::"'a ⇒ 'b" and g::"'a ⇒ 'c"
assumes "comparator c1" and "comparator c2" and "⋀x y. f x = f y ⟹ g x = g y ⟹ x = y"
shows "comparator (λx y. case c1 (f x) (f y) of Eq ⇒ c2 (g x) (g y) | val ⇒ val)"
(is "comparator ?c3")
proof -
from assms(1) interpret c1: comparator c1 .
from assms(2) interpret c2: comparator c2 .
show ?thesis
proof
fix x y :: 'a
show "invert_order (?c3 x y) = ?c3 y x"
by (simp add: c1.eq c2.eq split: order.split,
metis invert_order.simps(1) invert_order.simps(2) c1.sym c2.sym order.distinct(5))
next
fix x y :: 'a
assume "?c3 x y = Eq"
hence "f x = f y" and "g x = g y" by (simp_all add: c1.eq c2.eq split: order.splits if_split_asm)
thus "x = y" by (rule assms(3))
next
fix x y z :: 'a
assume "?c3 x y = Lt"
hence d1: "c1 (f x) (f y) = Lt ∨ (c1 (f x) (f y) = Eq ∧ c2 (g x) (g y) = Lt)"
by (simp split: order.splits)
assume "?c3 y z = Lt"
hence d2: "c1 (f y) (f z) = Lt ∨ (c1 (f y) (f z) = Eq ∧ c2 (g y) (g z) = Lt)"
by (simp split: order.splits)
from d1 show "?c3 x z = Lt"
proof
assume 1: "c1 (f x) (f y) = Lt"
from d2 show ?thesis
proof
assume "c1 (f y) (f z) = Lt"
with 1 have "c1 (f x) (f z) = Lt" by (rule c1.trans)
thus ?thesis by simp
next
assume "c1 (f y) (f z) = Eq ∧ c2 (g y) (g z) = Lt"
hence "f z = f y" and "c2 (g y) (g z) = Lt" by (simp_all add: c1.eq)
with 1 show ?thesis by simp
qed
next
assume "c1 (f x) (f y) = Eq ∧ c2 (g x) (g y) = Lt"
hence 1: "f x = f y" and 2: "c2 (g x) (g y) = Lt" by (simp_all add: c1.eq)
from d2 show ?thesis
proof
assume "c1 (f y) (f z) = Lt"
thus ?thesis by (simp add: 1)
next
assume "c1 (f y) (f z) = Eq ∧ c2 (g y) (g z) = Lt"
hence 3: "f y = f z" and "c2 (g y) (g z) = Lt" by (simp_all add: c1.eq)
from 2 this(2) have "c2 (g x) (g z) = Lt" by (rule c2.trans)
thus ?thesis by (simp add: 1 3)
qed
qed
qed
qed
class nat_term =
fixes rep_nat_term :: "'a ⇒ ((nat, nat) pp × nat)"
and splus :: "'a ⇒ 'a ⇒ 'a"
assumes rep_nat_term_inj: "rep_nat_term x = rep_nat_term y ⟹ x = y"
and full_component: "snd (rep_nat_term x) = i ⟹ (∃y. rep_nat_term y = (t, i))"
and splus_term: "rep_nat_term (splus x y) = pprod.splus (fst (rep_nat_term x)) (rep_nat_term y)"
begin
definition "lex_comp_aux = (λx y. case comp_of_ord lex_pp (fst (rep_nat_term x)) (fst (rep_nat_term y)) of
Eq ⇒ comparator_of (snd (rep_nat_term x)) (snd (rep_nat_term y)) | val ⇒ val)"
lemma full_componentE:
assumes "snd (rep_nat_term x) = i"
obtains y where "rep_nat_term y = (t, i)"
proof -
from assms have "∃y. rep_nat_term y = (t, i)" by (rule full_component)
then obtain y where "rep_nat_term y = (t, i)" ..
thus ?thesis ..
qed
end
class nat_pp_term = nat_term + zero + plus +
assumes rep_nat_term_zero: "rep_nat_term 0 = (0, 0)"
and splus_pp_term: "splus = (+)"
definition nat_term_comp :: "'a::nat_term comparator ⇒ bool"
where "nat_term_comp cmp ⟷
(∀u v. snd (rep_nat_term u) = snd (rep_nat_term v) ⟶ fst (rep_nat_term u) = 0 ⟶ cmp u v ≠ Gt) ∧
(∀u v. fst (rep_nat_term u) = fst (rep_nat_term v) ⟶ snd (rep_nat_term u) < snd (rep_nat_term v) ⟶ cmp u v = Lt) ∧
(∀t u v. cmp u v = Lt ⟶ cmp (splus t u) (splus t v) = Lt) ∧
(∀u v a b. fst (rep_nat_term u) = fst (rep_nat_term a) ⟶ fst (rep_nat_term v) = fst (rep_nat_term b) ⟶
snd (rep_nat_term u) = snd (rep_nat_term v) ⟶ snd (rep_nat_term a) = snd (rep_nat_term b) ⟶
cmp a b = Lt ⟶ cmp u v = Lt)"
lemma nat_term_compI:
assumes "⋀u v. snd (rep_nat_term u) = snd (rep_nat_term v) ⟹ fst (rep_nat_term u) = 0 ⟹ cmp u v ≠ Gt"
and "⋀u v. fst (rep_nat_term u) = fst (rep_nat_term v) ⟹ snd (rep_nat_term u) < snd (rep_nat_term v) ⟹ cmp u v = Lt"
and "⋀t u v. cmp u v = Lt ⟹ cmp (splus t u) (splus t v) = Lt"
and "⋀u v a b. fst (rep_nat_term u) = fst (rep_nat_term a) ⟹ fst (rep_nat_term v) = fst (rep_nat_term b) ⟹
snd (rep_nat_term u) = snd (rep_nat_term v) ⟹ snd (rep_nat_term a) = snd (rep_nat_term b) ⟹
cmp a b = Lt ⟹ cmp u v = Lt"
shows "nat_term_comp cmp"
unfolding nat_term_comp_def fst_conv snd_conv using assms by blast
lemma nat_term_compD1:
assumes "nat_term_comp cmp" and "snd (rep_nat_term u) = snd (rep_nat_term v)" and "fst (rep_nat_term u) = 0"
shows "cmp u v ≠ Gt"
using assms unfolding nat_term_comp_def fst_conv by blast
lemma nat_term_compD2:
assumes "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term v)" and "snd (rep_nat_term u) < snd (rep_nat_term v)"
shows "cmp u v = Lt"
using assms unfolding nat_term_comp_def fst_conv snd_conv by blast
lemma nat_term_compD3:
assumes "nat_term_comp cmp" and "cmp u v = Lt"
shows "cmp (splus t u) (splus t v) = Lt"
using assms unfolding nat_term_comp_def snd_conv by blast
lemma nat_term_compD4:
assumes "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term a)"
and "fst (rep_nat_term v) = fst (rep_nat_term b)" and "snd (rep_nat_term u) = snd (rep_nat_term v)"
and "snd (rep_nat_term a) = snd (rep_nat_term b)" and "cmp a b = Lt"
shows "cmp u v = Lt"
using assms unfolding nat_term_comp_def snd_conv by blast
lemma nat_term_compD1':
assumes "comparator cmp" and "nat_term_comp cmp" and "snd (rep_nat_term u) ≤ snd (rep_nat_term v)"
and "fst (rep_nat_term u) = 0"
shows "cmp u v ≠ Gt"
proof (cases "snd (rep_nat_term u) = snd (rep_nat_term v)")
case True
with assms(2) show ?thesis using assms(4) by (rule nat_term_compD1)
next
from assms(1) interpret cmp: comparator cmp .
case False
with assms(3) have a: "snd (rep_nat_term u) < snd (rep_nat_term v)" by simp
from refl obtain w::'a where eq: "rep_nat_term w = (0, snd (rep_nat_term v))" by (rule full_componentE)
have "cmp u w = Lt" by (rule nat_term_compD2, fact assms(2), simp_all add: eq assms(4) a)
moreover have "cmp w v ≠ Gt" by (rule nat_term_compD1, fact assms(2), simp_all add: eq)
ultimately show "cmp u v ≠ Gt" by (simp add: cmp.nGt_le_conv cmp.Lt_lt_conv)
qed
lemma nat_term_compD4':
assumes "comparator cmp" and "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term a)"
and "fst (rep_nat_term v) = fst (rep_nat_term b)" and "snd (rep_nat_term u) = snd (rep_nat_term v)"
and "snd (rep_nat_term a) = snd (rep_nat_term b)"
shows "cmp u v = cmp a b"
proof -
from assms(1) interpret cmp: comparator cmp .
show ?thesis
proof (cases "cmp a b")
case Eq
hence "fst (rep_nat_term u) = fst (rep_nat_term v)" by (simp add: cmp.eq assms(3, 4))
hence "rep_nat_term u = rep_nat_term v" using assms(5) by (rule prod_eqI)
hence "u = v" by (rule rep_nat_term_inj)
thus ?thesis by (simp add: Eq)
next
case Lt
with assms(2, 3, 4, 5, 6) have "cmp u v = Lt" by (rule nat_term_compD4)
thus ?thesis by (simp add: Lt)
next
case Gt
hence "cmp b a = Lt" by (simp only: cmp.Gt_lt_conv cmp.Lt_lt_conv)
with assms(2, 4, 3) assms(5, 6)[symmetric] have "cmp v u = Lt" by (rule nat_term_compD4)
hence "cmp u v = Gt" by (simp only: cmp.Gt_lt_conv cmp.Lt_lt_conv)
thus ?thesis by (simp add: Gt)
qed
qed
lemma nat_term_compD4'':
assumes "comparator cmp" and "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term a)"
and "fst (rep_nat_term v) = fst (rep_nat_term b)" and "snd (rep_nat_term u) ≤ snd (rep_nat_term v)"
and "snd (rep_nat_term a) = snd (rep_nat_term b)" and "cmp a b ≠ Gt"
shows "cmp u v ≠ Gt"
proof (cases "snd (rep_nat_term u) = snd (rep_nat_term v)")
case True
with assms(1, 2, 3, 4) have "cmp u v = cmp a b" using assms(6) by (rule nat_term_compD4')
thus ?thesis using assms(7) by simp
next
case False
from assms(1) interpret cmp: comparator cmp .
from refl obtain w::'a where w: "rep_nat_term w = (fst (rep_nat_term u), snd (rep_nat_term v))"
by (rule full_componentE)
have 1: "fst (rep_nat_term w) = fst (rep_nat_term a)" and 2: "snd (rep_nat_term w) = snd (rep_nat_term v)"
by (simp_all add: w assms(3))
from False assms(5) have *: "snd (rep_nat_term u) < snd (rep_nat_term v)" by simp
have "cmp u w = Lt" by (rule nat_term_compD2, fact assms(2), simp_all add: * w)
moreover from assms(1, 2) 1 assms(4) 2 assms(6) have "cmp w v = cmp a b" by (rule nat_term_compD4')
ultimately show ?thesis using assms(7) by (metis cmp.nGt_le_conv cmp.nLt_le_conv cmp.trans)
qed
lemma comparator_lex_comp_aux: "comparator (lex_comp_aux::'a::nat_term comparator)"
unfolding lex_comp_aux_def
proof (rule comparator_composition)
from lex_pp_antisym have as: "antisymp lex_pp" by (rule antisympI)
have "comparator (comp_of_ord (lex_pp::(nat, nat) pp ⇒ _))"
unfolding comp_of_ord_eq_comp_of_ords[OF as]
by (rule comp_of_ords, unfold_locales,
auto simp: lex_pp_refl intro: lex_pp_trans lex_pp_lin' elim!: lex_pp_antisym)
thus "comparator (λx y::((nat, nat) pp × nat). case comp_of_ord lex_pp (fst x) (fst y) of
Eq ⇒ comparator_of (snd x) (snd y) | val ⇒ val)"
using comparator_of prod_eqI by (rule comparator_lexicographic)
next
from rep_nat_term_inj show "inj rep_nat_term" by (rule injI)
qed
lemma nat_term_comp_lex_comp_aux: "nat_term_comp (lex_comp_aux::'a::nat_term comparator)"
proof -
from lex_pp_antisym have as: "antisymp lex_pp" by (rule antisympI)
interpret lex: comparator "comp_of_ord (lex_pp::(nat, nat) pp ⇒ _)"
unfolding comp_of_ord_eq_comp_of_ords[OF as]
by (rule comp_of_ords, unfold_locales,
auto simp: lex_pp_refl intro: lex_pp_trans lex_pp_lin' elim!: lex_pp_antisym)
show ?thesis
proof (rule nat_term_compI)
fix u v :: 'a
assume 1: "snd (rep_nat_term u) = snd (rep_nat_term v)" and 2: "fst (rep_nat_term u) = 0"
show "lex_comp_aux u v ≠ Gt"
by (simp add: lex_comp_aux_def 1 2 split: order.split, simp add: comp_of_ord_def lex_pp_zero_min)
next
fix u v :: 'a
assume 1: "fst (rep_nat_term u) = fst (rep_nat_term v)" and 2: "snd (rep_nat_term u) < snd (rep_nat_term v)"
show "lex_comp_aux u v = Lt"
by (simp add: lex_comp_aux_def 1 split: order.split, simp add: comparator_of_def 2)
next
fix t u v :: 'a
show "lex_comp_aux u v = Lt ⟹ lex_comp_aux (splus t u) (splus t v) = Lt"
by (auto simp: lex_comp_aux_def splus_term pprod.splus_def comp_of_ord_def lex_pp_refl
split: order.splits if_splits intro: lex_pp_plus_monotone')
next
fix u v a b :: 'a
assume "fst (rep_nat_term u) = fst (rep_nat_term a)" and "fst (rep_nat_term v) = fst (rep_nat_term b)"
and "snd (rep_nat_term a) = snd (rep_nat_term b)" and "lex_comp_aux a b = Lt"
thus "lex_comp_aux u v = Lt" by (simp add: lex_comp_aux_def split: order.splits)
qed
qed
typedef (overloaded) 'a nat_term_order =
"{cmp::'a::nat_term comparator. comparator cmp ∧ nat_term_comp cmp}"
morphisms nat_term_compare Abs_nat_term_order
proof (rule, simp)
from comparator_lex_comp_aux nat_term_comp_lex_comp_aux
show "comparator lex_comp_aux ∧ nat_term_comp lex_comp_aux" ..
qed
lemma nat_term_compare_Abs_nat_term_order_id:
assumes "comparator cmp" and "nat_term_comp cmp"
shows "nat_term_compare (Abs_nat_term_order cmp) = cmp"
by (rule Abs_nat_term_order_inverse, simp add: assms)
instantiation nat_term_order :: (type) equal
begin
definition equal_nat_term_order :: "'a nat_term_order ⇒ 'a nat_term_order ⇒ bool" where "equal_nat_term_order = (=)"
instance by (standard, simp add: equal_nat_term_order_def)
end
definition nat_term_compare_inv :: "'a nat_term_order ⇒ 'a::nat_term comparator"
where "nat_term_compare_inv to = (λx y. nat_term_compare to y x)"
definition key_order_of_nat_term_order :: "'a nat_term_order ⇒ 'a::nat_term key_order"
where key_order_of_nat_term_order_def [code del]:
"key_order_of_nat_term_order to = Abs_key_order (nat_term_compare to)"
definition key_order_of_nat_term_order_inv :: "'a nat_term_order ⇒ 'a::nat_term key_order"
where key_order_of_nat_term_order_inv_def [code del]:
"key_order_of_nat_term_order_inv to = Abs_key_order (nat_term_compare_inv to)"
definition le_of_nat_term_order :: "'a nat_term_order ⇒ 'a ⇒ 'a::nat_term ⇒ bool"
where "le_of_nat_term_order to = le_of_key_order (key_order_of_nat_term_order to)"
definition lt_of_nat_term_order :: "'a nat_term_order ⇒ 'a ⇒ 'a::nat_term ⇒ bool"
where "lt_of_nat_term_order to = lt_of_key_order (key_order_of_nat_term_order to)"
definition nat_term_order_of_le :: "'a::{linorder,nat_term} nat_term_order"
where "nat_term_order_of_le = Abs_nat_term_order (comparator_of)"
lemma comparator_nat_term_compare: "comparator (nat_term_compare to)"
using nat_term_compare by blast
lemma nat_term_comp_nat_term_compare: "nat_term_comp (nat_term_compare to)"
using nat_term_compare by blast
lemma nat_term_compare_splus: "nat_term_compare to (splus t u) (splus t v) = nat_term_compare to u v"
proof -
from comparator_nat_term_compare interpret cmp: comparator "nat_term_compare to" .
show ?thesis
proof (cases "nat_term_compare to u v")
case Eq
hence "splus t u = splus t v" by (simp add: cmp.eq)
thus ?thesis by (simp add: cmp.eq Eq)
next
case Lt
moreover from nat_term_comp_nat_term_compare this have "nat_term_compare to (splus t u) (splus t v) = Lt"
by (rule nat_term_compD3)
ultimately show ?thesis by simp
next
case Gt
hence "nat_term_compare to v u = Lt" using cmp.Gt_lt_conv cmp.Lt_lt_conv by auto
with nat_term_comp_nat_term_compare have "nat_term_compare to (splus t v) (splus t u) = Lt"
by (rule nat_term_compD3)
hence "nat_term_compare to (splus t u) (splus t v) = Gt" using cmp.Gt_lt_conv cmp.Lt_lt_conv by auto
with Gt show ?thesis by simp
qed
qed
lemma nat_term_compare_conv: "nat_term_compare to = key_compare (key_order_of_nat_term_order to)"
unfolding key_order_of_nat_term_order_def
by (rule sym, rule Abs_key_order_inverse, simp add: comparator_nat_term_compare)
lemma comparator_nat_term_compare_inv: "comparator (nat_term_compare_inv to)"
unfolding nat_term_compare_inv_def using comparator_nat_term_compare by (rule comparator_converse)
lemma nat_term_compare_inv_conv: "nat_term_compare_inv to = key_compare (key_order_of_nat_term_order_inv to)"
unfolding key_order_of_nat_term_order_inv_def
by (rule sym, rule Abs_key_order_inverse, simp add: comparator_nat_term_compare_inv)
lemma nat_term_compare_inv_alt [code_unfold]: "nat_term_compare_inv to x y = nat_term_compare to y x"
by (simp only: nat_term_compare_inv_def)
lemma le_of_nat_term_order [code]: "le_of_nat_term_order to x y = (nat_term_compare to x y ≠ Gt)"
by (simp add: le_of_key_order_alt le_of_nat_term_order_def nat_term_compare_conv)
lemma lt_of_nat_term_order [code]: "lt_of_nat_term_order to x y = (nat_term_compare to x y = Lt)"
by (simp add: lt_of_key_order_alt lt_of_nat_term_order_def nat_term_compare_conv)
lemma le_of_nat_term_order_alt:
"le_of_nat_term_order to = (λu v. ko.le (key_order_of_nat_term_order_inv to) v u)"
by (intro ext, simp add: le_of_comp_def nat_term_compare_inv_conv[symmetric] le_of_nat_term_order_def
le_of_key_order_def nat_term_compare_conv[symmetric] nat_term_compare_inv_alt)
lemma lt_of_nat_term_order_alt:
"lt_of_nat_term_order to = (λu v. ko.lt (key_order_of_nat_term_order_inv to) v u)"
by (intro ext, simp add: lt_of_comp_def nat_term_compare_inv_conv[symmetric] lt_of_nat_term_order_def
lt_of_key_order_def nat_term_compare_conv[symmetric] nat_term_compare_inv_alt)
lemma linorder_le_of_nat_term_order: "class.linorder (le_of_nat_term_order to) (lt_of_nat_term_order to)"
unfolding le_of_nat_term_order_alt lt_of_nat_term_order_alt using ko.linorder
by (rule linorder.dual_linorder)
lemma le_of_nat_term_order_zero_min: "le_of_nat_term_order to 0 (t::'a::nat_pp_term)"
unfolding le_of_nat_term_order
by (rule nat_term_compD1', fact comparator_nat_term_compare, fact nat_term_comp_nat_term_compare, simp_all add: rep_nat_term_zero)
lemma le_of_nat_term_order_plus_monotone:
assumes "le_of_nat_term_order to s (t::'a::nat_pp_term)"
shows "le_of_nat_term_order to (u + s) (u + t)"
using assms by (simp add: le_of_nat_term_order splus_pp_term[symmetric] nat_term_compare_splus)
global_interpretation ko_ntm: comparator "nat_term_compare_inv ko"
defines lookup_pair_ko_ntm = ko_ntm.lookup_pair
and update_by_pair_ko_ntm = ko_ntm.update_by_pair
and update_by_fun_pair_ko_ntm = ko_ntm.update_by_fun_pair
and update_by_fun_gr_pair_ko_ntm = ko_ntm.update_by_fun_gr_pair
and map2_val_pair_ko_ntm = ko_ntm.map2_val_pair
and lex_ord_pair_ko_ntm = ko_ntm.lex_ord_pair
and prod_ord_pair_ko_ntm = ko_ntm.prod_ord_pair
and sort_oalist_ko_ntm' = ko_ntm.sort_oalist
by (fact comparator_nat_term_compare_inv)
lemma ko_ntm_le: "ko_ntm.le to = (λx y. le_of_nat_term_order to y x)"
by (intro ext, simp add: le_of_comp_def le_of_nat_term_order nat_term_compare_inv_def split: order.split)
global_interpretation ko_ntm: oalist_raw key_order_of_nat_term_order_inv
rewrites "comparator.lookup_pair (key_compare (key_order_of_nat_term_order_inv ko)) = lookup_pair_ko_ntm ko"
and "comparator.update_by_pair (key_compare (key_order_of_nat_term_order_inv ko)) = update_by_pair_ko_ntm ko"
and "comparator.update_by_fun_pair (key_compare (key_order_of_nat_term_order_inv ko)) = update_by_fun_pair_ko_ntm ko"
and "comparator.update_by_fun_gr_pair (key_compare (key_order_of_nat_term_order_inv ko)) = update_by_fun_gr_pair_ko_ntm ko"
and "comparator.map2_val_pair (key_compare (key_order_of_nat_term_order_inv ko)) = map2_val_pair_ko_ntm ko"
and "comparator.lex_ord_pair (key_compare (key_order_of_nat_term_order_inv ko)) = lex_ord_pair_ko_ntm ko"
and "comparator.prod_ord_pair (key_compare (key_order_of_nat_term_order_inv ko)) = prod_ord_pair_ko_ntm ko"
and "comparator.sort_oalist (key_compare (key_order_of_nat_term_order_inv ko)) = sort_oalist_ko_ntm' ko"
defines sort_oalist_aux_ko_ntm = ko_ntm.sort_oalist_aux
and lookup_ko_ntm = ko_ntm.lookup_raw
and sorted_domain_ko_ntm = ko_ntm.sorted_domain_raw
and tl_ko_ntm = ko_ntm.tl_raw
and min_key_val_ko_ntm = ko_ntm.min_key_val_raw
and update_by_ko_ntm = ko_ntm.update_by_raw
and update_by_fun_ko_ntm = ko_ntm.update_by_fun_raw
and update_by_fun_gr_ko_ntm = ko_ntm.update_by_fun_gr_raw
and map2_val_ko_ntm = ko_ntm.map2_val_raw
and lex_ord_ko_ntm = ko_ntm.lex_ord_raw
and prod_ord_ko_ntm = ko_ntm.prod_ord_raw
and oalist_eq_ko_ntm = ko_ntm.oalist_eq_raw
and sort_oalist_ko_ntm = ko_ntm.sort_oalist_raw
subgoal by (simp only: lookup_pair_ko_ntm_def nat_term_compare_inv_conv)
subgoal by (simp only: update_by_pair_ko_ntm_def nat_term_compare_inv_conv)
subgoal by (simp only: update_by_fun_pair_ko_ntm_def nat_term_compare_inv_conv)
subgoal by (simp only: update_by_fun_gr_pair_ko_ntm_def nat_term_compare_inv_conv)
subgoal by (simp only: map2_val_pair_ko_ntm_def nat_term_compare_inv_conv)
subgoal by (simp only: lex_ord_pair_ko_ntm_def nat_term_compare_inv_conv)
subgoal by (simp only: prod_ord_pair_ko_ntm_def nat_term_compare_inv_conv)
subgoal by (simp only: sort_oalist_ko_ntm'_def nat_term_compare_inv_conv)
done
lemma compute_min_key_val_ko_ntm [code]:
"min_key_val_ko_ntm ko (xs, ox) =
(if ko = ox then hd else min_list_param (λx y. (le_of_nat_term_order ko) (fst y) (fst x))) xs"
proof -
have "ko.le (key_order_of_nat_term_order_inv ko) = (λx y. le_of_nat_term_order ko y x)"
by (metis ko.nGt_le_conv le_of_nat_term_order nat_term_compare_inv_conv nat_term_compare_inv_def)
thus ?thesis by (simp only: min_key_val_ko_ntm_def oalist_raw.min_key_val_raw.simps)
qed
typedef (overloaded) ('a, 'b) oalist_ntm =
"{xs::('a, 'b::zero, 'a::nat_term nat_term_order) oalist_raw. ko_ntm.oalist_inv xs}"
morphisms list_of_oalist_ntm Abs_oalist_ntm
by (auto simp: ko_ntm.oalist_inv_def intro: ko.oalist_inv_raw_Nil)
lemma oalist_ntm_eq_iff: "xs = ys ⟷ list_of_oalist_ntm xs = list_of_oalist_ntm ys"
by (simp add: list_of_oalist_ntm_inject)
lemma oalist_ntm_eqI: "list_of_oalist_ntm xs = list_of_oalist_ntm ys ⟹ xs = ys"
by (simp add: oalist_ntm_eq_iff)
text ‹Formal, totalized constructor for @{typ "('a, 'b) oalist_ntm"}:›
definition OAlist_ntm :: "('a × 'b) list × 'a nat_term_order ⇒ ('a::nat_term, 'b::zero) oalist_ntm"
where "OAlist_ntm xs = Abs_oalist_ntm (sort_oalist_ko_ntm xs)"
definition "oalist_of_list_ntm = OAlist_ntm"
lemma oalist_inv_list_of_oalist_ntm: "ko_ntm.oalist_inv (list_of_oalist_ntm xs)"
using list_of_oalist_ntm[of xs] by simp
lemma list_of_oalist_OAlist_ntm: "list_of_oalist_ntm (OAlist_ntm xs) = sort_oalist_ko_ntm xs"
proof -
obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
have "ko_ntm.oalist_inv (sort_oalist_ko_ntm' ox xs', ox)"
using ko_ntm.oalist_inv_sort_oalist_raw by fastforce
thus ?thesis by (simp add: xs OAlist_ntm_def Abs_oalist_ntm_inverse)
qed
lemma OAlist_list_of_oalist_ntm [simp, code abstype]: "OAlist_ntm (list_of_oalist_ntm xs) = xs"
proof -
obtain xs' ox where xs: "list_of_oalist_ntm xs = (xs', ox)" by fastforce
have "ko_ntm.oalist_inv_raw ox xs'"
by (simp add: xs[symmetric] ko_ntm.oalist_inv_alt[symmetric] nat_term_compare_inv_conv oalist_inv_list_of_oalist_ntm)
thus ?thesis by (simp add: xs OAlist_ntm_def ko_ntm.sort_oalist_id, simp add: list_of_oalist_ntm_inverse xs[symmetric])
qed
lemma [code abstract]: "list_of_oalist_ntm (oalist_of_list_ntm xs) = sort_oalist_ko_ntm xs"
by (simp add: list_of_oalist_OAlist_ntm oalist_of_list_ntm_def)
global_interpretation oa_ntm: oalist_abstract key_order_of_nat_term_order_inv list_of_oalist_ntm OAlist_ntm
defines OAlist_lookup_ntm = oa_ntm.lookup
and OAlist_sorted_domain_ntm = oa_ntm.sorted_domain
and OAlist_empty_ntm = oa_ntm.empty
and OAlist_reorder_ntm = oa_ntm.reorder
and OAlist_tl_ntm = oa_ntm.tl
and OAlist_hd_ntm = oa_ntm.hd
and OAlist_except_min_ntm = oa_ntm.except_min
and OAlist_min_key_val_ntm = oa_ntm.min_key_val
and OAlist_insert_ntm = oa_ntm.insert
and OAlist_update_by_fun_ntm = oa_ntm.update_by_fun
and OAlist_update_by_fun_gr_ntm = oa_ntm.update_by_fun_gr
and OAlist_filter_ntm = oa_ntm.filter
and OAlist_map2_val_neutr_ntm = oa_ntm.map2_val_neutr
and OAlist_eq_ntm = oa_ntm.oalist_eq
apply unfold_locales
subgoal by (fact oalist_inv_list_of_oalist_ntm)
subgoal by (simp only: list_of_oalist_OAlist_ntm sort_oalist_ko_ntm_def)
subgoal by (fact OAlist_list_of_oalist_ntm)
done
global_interpretation oa_ntm: oalist_abstract3 key_order_of_nat_term_order_inv
"list_of_oalist_ntm::('a, 'b) oalist_ntm ⇒ ('a, 'b::zero, 'a::nat_term nat_term_order) oalist_raw" OAlist_ntm
"list_of_oalist_ntm::('a, 'c) oalist_ntm ⇒ ('a, 'c::zero, 'a nat_term_order) oalist_raw" OAlist_ntm
"list_of_oalist_ntm::('a, 'd) oalist_ntm ⇒ ('a, 'd::zero, 'a nat_term_order) oalist_raw" OAlist_ntm
defines OAlist_map_val_ntm = oa_ntm.map_val
and OAlist_map2_val_ntm = oa_ntm.map2_val
and OAlist_map2_val_rneutr_ntm = oa_ntm.map2_val_rneutr
and OAlist_lex_ord_ntm = oa_ntm.lex_ord
and OAlist_prod_ord_ntm = oa_ntm.prod_ord ..
lemmas OAlist_lookup_ntm_single = oa_ntm.lookup_oalist_of_list_single[folded oalist_of_list_ntm_def]
end
Theory Term_Order
section ‹Computable Term Orders›
theory Term_Order
imports OAlist_Poly_Mapping "HOL-Library.Product_Lexorder"
begin
subsection ‹Type Class ‹nat››
class nat = zero + plus + minus + order + equal +
fixes rep_nat :: "'a ⇒ nat"
and abs_nat :: "nat ⇒ 'a"
assumes rep_inverse [simp]: "abs_nat (rep_nat x) = x"
and abs_inverse [simp]: "rep_nat (abs_nat n) = n"
and abs_zero [simp]: "abs_nat 0 = 0"
and abs_plus: "abs_nat m + abs_nat n = abs_nat (m + n)"
and abs_minus: "abs_nat m - abs_nat n = abs_nat (m - n)"
and abs_ord: "m ≤ n ⟹ abs_nat m ≤ abs_nat n"
begin
lemma rep_inj:
assumes "rep_nat x = rep_nat y"
shows "x = y"
proof -
have "abs_nat (rep_nat x) = abs_nat (rep_nat y)" by (simp only: assms)
thus ?thesis by (simp only: rep_inverse)
qed
corollary rep_eq_iff: "(rep_nat x = rep_nat y) ⟷ (x = y)"
by (auto elim: rep_inj)
lemma abs_inj:
assumes "abs_nat m = abs_nat n"
shows "m = n"
proof -
have "rep_nat (abs_nat m) = rep_nat (abs_nat n)" by (simp only: assms)
thus ?thesis by (simp only: abs_inverse)
qed
corollary abs_eq_iff: "(abs_nat m = abs_nat n) ⟷ (m = n)"
by (auto elim: abs_inj)
lemma rep_zero [simp]: "rep_nat 0 = 0"
using abs_inverse abs_zero by fastforce
lemma rep_zero_iff: "(rep_nat x = 0) ⟷ (x = 0)"
using rep_eq_iff by fastforce
lemma plus_eq: "x + y = abs_nat (rep_nat x + rep_nat y)"
by (metis abs_plus rep_inverse)
lemma rep_plus: "rep_nat (x + y) = rep_nat x + rep_nat y"
by (simp add: plus_eq)
lemma minus_eq: "x - y = abs_nat (rep_nat x - rep_nat y)"
by (metis abs_minus rep_inverse)
lemma rep_minus: "rep_nat (x - y) = rep_nat x - rep_nat y"
by (simp add: minus_eq)
lemma ord_iff:
"x ≤ y ⟷ rep_nat x ≤ rep_nat y" (is ?thesis1)
"x < y ⟷ rep_nat x < rep_nat y" (is ?thesis2)
proof -
show ?thesis1
proof
assume "x ≤ y"
show "rep_nat x ≤ rep_nat y"
proof (rule ccontr)
assume "¬ rep_nat x ≤ rep_nat y"
hence "rep_nat y ≤ rep_nat x" and "rep_nat x ≠ rep_nat y" by simp_all
from this(1) have "abs_nat (rep_nat y) ≤ abs_nat (rep_nat x)" by (rule abs_ord)
hence "y ≤ x" by (simp only: rep_inverse)
moreover from ‹rep_nat x ≠ rep_nat y› have "y ≠ x" using rep_inj by auto
ultimately have "y < x" by simp
with ‹x ≤ y› show False by simp
qed
next
assume "rep_nat x ≤ rep_nat y"
hence "abs_nat (rep_nat x) ≤ abs_nat (rep_nat y)" by (rule abs_ord)
thus "x ≤ y" by (simp only: rep_inverse)
qed
thus ?thesis2 using rep_inj[of x y] by (auto simp: less_le Nat.nat_less_le)
qed
lemma ex_iff_abs: "(∃x::'a. P x) ⟷ (∃n::nat. P (abs_nat n))"
by (metis rep_inverse)
lemma ex_iff_abs': "(∃x<abs_nat m. P x) ⟷ (∃n::nat<m. P (abs_nat n))"
by (metis abs_inverse rep_inverse ord_iff(2))
lemma all_iff_abs: "(∀x::'a. P x) ⟷ (∀n::nat. P (abs_nat n))"
by (metis rep_inverse)
lemma all_iff_abs': "(∀x<abs_nat m. P x) ⟷ (∀n::nat<m. P (abs_nat n))"
by (metis abs_inverse rep_inverse ord_iff(2))
subclass linorder by (standard, auto simp: ord_iff rep_inj)
lemma comparator_of_rep [simp]: "comparator_of (rep_nat x) (rep_nat y) = comparator_of x y"
by (simp add: comparator_of_def linorder_class.comparator_of_def ord_iff rep_inj)
subclass wellorder
proof
fix P::"'a ⇒ bool" and a::'a
let ?P = "λn::nat. P (abs_nat n)"
assume a: "⋀x. (⋀y. y < x ⟹ P y) ⟹ P x"
have "P (abs_nat (rep_nat a))"
proof (rule less_induct[of _ "rep_nat a"])
fix n::nat
assume b: "⋀m. m < n ⟹ ?P m"
show "?P n"
proof (rule a)
fix y
assume "y < abs_nat n"
hence "rep_nat y < n" by (simp only: ord_iff abs_inverse)
hence "?P (rep_nat y)" by (rule b)
thus "P y" by (simp only: rep_inverse)
qed
qed
thus "P a" by (simp only: rep_inverse)
qed
subclass comm_monoid_add by (standard, auto simp: plus_eq intro: arg_cong)
lemma sum_rep: "sum (rep_nat ∘ f) A = rep_nat (sum f A)" for f :: "'b ⇒ 'a" and A :: "'b set"
proof (induct A rule: infinite_finite_induct)
case (infinite A)
thus ?case by simp
next
case empty
show ?case by simp
next
case (insert a A)
from insert(1, 2) show ?case by (simp del: comp_apply add: insert(3) rep_plus, simp)
qed
subclass ordered_comm_monoid_add by (standard, simp add: ord_iff plus_eq)
subclass countable by intro_classes (intro exI[of _ rep_nat] injI, elim rep_inj)
subclass cancel_comm_monoid_add
apply standard
subgoal by (simp add: minus_eq rep_plus)
subgoal by (simp add: minus_eq rep_plus)
done
subclass add_wellorder
apply standard
subgoal by (simp add: ord_iff rep_plus)
subgoal unfolding ord_iff by (drule le_imp_add, metis abs_plus rep_inverse)
subgoal by (simp add: ord_iff)
done
end
lemma the_min_eq_zero: "the_min = (0::'a::{the_min,nat})"
proof -
have "the_min ≤ (0::'a)" by (fact the_min_min)
hence "rep_nat (the_min::'a) ≤ rep_nat (0::'a)" by (simp only: ord_iff)
also have "... = 0" by simp
finally have "rep_nat (the_min::'a) = 0" by simp
thus ?thesis by (simp only: rep_zero_iff)
qed
instantiation nat :: nat
begin
definition rep_nat_nat :: "nat ⇒ nat" where rep_nat_nat_def [code_unfold]: "rep_nat_nat = (λx. x)"
definition abs_nat_nat :: "nat ⇒ nat" where abs_nat_nat_def [code_unfold]: "abs_nat_nat = (λx. x)"
instance by (standard, simp_all add: rep_nat_nat_def abs_nat_nat_def)
end
instantiation natural :: nat
begin
definition rep_nat_natural :: "natural ⇒ nat"
where rep_nat_natural_def [code_unfold]: "rep_nat_natural = nat_of_natural"
definition abs_nat_natural :: "nat ⇒ natural"
where abs_nat_natural_def [code_unfold]: "abs_nat_natural = natural_of_nat"
instance by (standard, simp_all add: rep_nat_natural_def abs_nat_natural_def, metis minus_natural.rep_eq nat_of_natural_of_nat of_nat_of_natural)
end
subsection ‹Term Orders›
subsubsection ‹Type Classes›
class nat_pp_compare = linorder + zero + plus +
fixes rep_nat_pp :: "'a ⇒ (nat, nat) pp"
and abs_nat_pp :: "(nat, nat) pp ⇒ 'a"
and lex_comp' :: "'a comparator"
and deg' :: "'a ⇒ nat"
assumes rep_nat_pp_inverse [simp]: "abs_nat_pp (rep_nat_pp x) = x"
and abs_nat_pp_inverse [simp]: "rep_nat_pp (abs_nat_pp t) = t"
and lex_comp': "lex_comp' x y = comp_of_ord lex_pp (rep_nat_pp x) (rep_nat_pp y)"
and deg': "deg' x = deg_pp (rep_nat_pp x)"
and le_pp: "rep_nat_pp x ≤ rep_nat_pp y ⟹ x ≤ y"
and zero_pp: "rep_nat_pp 0 = 0"
and plus_pp: "rep_nat_pp (x + y) = rep_nat_pp x + rep_nat_pp y"
begin
lemma less_pp:
assumes "rep_nat_pp x < rep_nat_pp y"
shows "x < y"
proof -
from assms have 1: "rep_nat_pp x ≤ rep_nat_pp y" and 2: "rep_nat_pp x ≠ rep_nat_pp y" by simp_all
from 1 have "x ≤ y" by (rule le_pp)
moreover from 2 have "x ≠ y" by auto
ultimately show ?thesis by simp
qed
lemma rep_nat_pp_inj:
assumes "rep_nat_pp x = rep_nat_pp y"
shows "x = y"
proof -
have "abs_nat_pp (rep_nat_pp x) = abs_nat_pp (rep_nat_pp y)" by (simp only: assms)
thus ?thesis by simp
qed
lemma lex_comp'_EqD:
assumes "lex_comp' x y = Eq"
shows "x = y"
proof (rule rep_nat_pp_inj)
from assms show "rep_nat_pp x = rep_nat_pp y" by (simp add: lex_comp' comp_of_ord_def split: if_split_asm)
qed
lemma lex_comp'_valE:
assumes "lex_comp' s t ≠ Eq"
obtains x where "x ∈ keys_pp (rep_nat_pp s) ∪ keys_pp (rep_nat_pp t)"
and "comparator_of (lookup_pp (rep_nat_pp s) x) (lookup_pp (rep_nat_pp t) x) = lex_comp' s t"
and "⋀y. y < x ⟹ lookup_pp (rep_nat_pp s) y = lookup_pp (rep_nat_pp t) y"
proof (cases "lex_comp' s t")
case Eq
with assms show ?thesis ..
next
case Lt
hence "rep_nat_pp s ≠ rep_nat_pp t" and "lex_pp (rep_nat_pp s) (rep_nat_pp t)"
by (auto simp: lex_comp' comp_of_ord_def split: if_split_asm)
hence "∃x. lookup_pp (rep_nat_pp s) x < lookup_pp (rep_nat_pp t) x ∧
(∀y<x. lookup_pp (rep_nat_pp s) y = lookup_pp (rep_nat_pp t) y)"
by (simp add: lex_pp_alt)
then obtain x where 1: "lookup_pp (rep_nat_pp s) x < lookup_pp (rep_nat_pp t) x"
and 2: "⋀y. y < x ⟹ lookup_pp (rep_nat_pp s) y = lookup_pp (rep_nat_pp t) y" by blast
show ?thesis
proof
show "x ∈ keys_pp (rep_nat_pp s) ∪ keys_pp (rep_nat_pp t)"
proof (rule ccontr)
assume "x ∉ keys_pp (rep_nat_pp s) ∪ keys_pp (rep_nat_pp t)"
with 1 show False by (simp add: keys_pp_iff)
qed
next
show "comparator_of (lookup_pp (rep_nat_pp s) x) (lookup_pp (rep_nat_pp t) x) = lex_comp' s t"
by (simp add: linorder_class.comparator_of_def 1 Lt)
qed (fact 2)
next
case Gt
hence "¬ lex_pp (rep_nat_pp s) (rep_nat_pp t)"
by (auto simp: lex_comp' comp_of_ord_def split: if_split_asm)
hence "lex_pp (rep_nat_pp t) (rep_nat_pp s)" by (rule lex_pp_lin')
moreover have "rep_nat_pp t ≠ rep_nat_pp s"
proof
assume "rep_nat_pp t = rep_nat_pp s"
moreover from this have "lex_pp (rep_nat_pp s) (rep_nat_pp t)" by (simp add: lex_pp_refl)
ultimately have "lex_comp' s t = Eq" by (simp add: lex_comp' comp_of_ord_def)
with Gt show False by simp
qed
ultimately have "∃x. lookup_pp (rep_nat_pp t) x < lookup_pp (rep_nat_pp s) x ∧
(∀y<x. lookup_pp (rep_nat_pp t) y = lookup_pp (rep_nat_pp s) y)"
by (simp add: lex_pp_alt)
then obtain x where 1: "lookup_pp (rep_nat_pp t) x < lookup_pp (rep_nat_pp s) x"
and 2: "⋀y. y < x ⟹ lookup_pp (rep_nat_pp t) y = lookup_pp (rep_nat_pp s) y" by blast
show ?thesis
proof
show "x ∈ keys_pp (rep_nat_pp s) ∪ keys_pp (rep_nat_pp t)"
proof (rule ccontr)
assume "x ∉ keys_pp (rep_nat_pp s) ∪ keys_pp (rep_nat_pp t)"
with 1 show False by (simp add: keys_pp_iff)
qed
next
from 1 have "¬ lookup_pp (rep_nat_pp s) x < lookup_pp (rep_nat_pp t) x"
and "lookup_pp (rep_nat_pp s) x ≠ lookup_pp (rep_nat_pp t) x" by simp_all
thus "comparator_of (lookup_pp (rep_nat_pp s) x) (lookup_pp (rep_nat_pp t) x) = lex_comp' s t"
by (simp add: linorder_class.comparator_of_def Gt)
qed (simp add: 2)
qed
end
class nat_term_compare = linorder + nat_term +
fixes is_scalar :: "'a itself ⇒ bool"
and lex_comp :: "'a comparator"
and deg_comp :: "'a comparator ⇒ 'a comparator"
and pot_comp :: "'a comparator ⇒ 'a comparator"
assumes zero_component: "∃x. snd (rep_nat_term x) = 0"
and is_scalar: "is_scalar = (λ_. ∀x. snd (rep_nat_term x) = 0)"
and lex_comp: "lex_comp = lex_comp_aux"
and deg_comp: "deg_comp cmp = (λx y. case comparator_of (deg_pp (fst (rep_nat_term x))) (deg_pp (fst (rep_nat_term y))) of Eq ⇒ cmp x y | val ⇒ val)"
and pot_comp: "pot_comp cmp = (λx y. case comparator_of (snd (rep_nat_term x)) (snd (rep_nat_term y)) of Eq ⇒ cmp x y | val ⇒ val)"
and le_term: "rep_nat_term x ≤ rep_nat_term y ⟹ x ≤ y"
begin
text ‹There is no need to add something like ‹top_comp› for TOP orders to class @{class nat_term_compare},
because by default all comparators should @{emph ‹first›} compare power-products and @{emph ‹then›} positions.
‹lex_comp› obviously does.›
lemma less_term:
assumes "rep_nat_term x < rep_nat_term y"
shows "x < y"
proof -
from assms have 1: "rep_nat_term x ≤ rep_nat_term y" and 2: "rep_nat_term x ≠ rep_nat_term y" by simp_all
from 1 have "x ≤ y" by (rule le_term)
moreover from 2 have "x ≠ y" by auto
ultimately show ?thesis by simp
qed
lemma lex_comp_alt: "lex_comp = (comparator_of::'a comparator)"
proof -
from lex_pp_antisym have as: "antisymp lex_pp" by (rule antisympI)
interpret lex: comparator "comp_of_ord (lex_pp::(nat, nat) pp ⇒ _)"
unfolding comp_of_ord_eq_comp_of_ords[OF as]
by (rule comp_of_ords, unfold_locales,
auto simp: lex_pp_refl intro: lex_pp_trans lex_pp_lin' elim!: lex_pp_antisym)
have 1: "x = y" if "fst (rep_nat_term x) = fst (rep_nat_term y)"
and "snd (rep_nat_term x) = snd (rep_nat_term y)" for x y
by (rule rep_nat_term_inj, rule prod_eqI, fact+)
have 2: "x < y" if "fst (rep_nat_term x) = fst (rep_nat_term y)"
and "snd (rep_nat_term x) < snd (rep_nat_term y)" for x y
by (rule less_term, simp add: less_prod_def that)
have 3: False if "fst (rep_nat_term x) = fst (rep_nat_term y)"
and "¬ snd (rep_nat_term x) < snd (rep_nat_term y)" and "x < y" for x y
proof -
from that(2) have a: "snd (rep_nat_term y) ≤ snd (rep_nat_term x)" by simp
have "y ≤ x" by (rule le_term, simp add: less_eq_prod_def that(1) a)
also have "... < y" by fact
finally show False ..
qed
have 4: "x < y" if "fst (rep_nat_term x) ≠ fst (rep_nat_term y)"
and "lex_pp (fst (rep_nat_term x)) (fst (rep_nat_term y))" for x y
proof -
from that(2) have "fst (rep_nat_term x) ≤ fst (rep_nat_term y)" by (simp only: less_eq_pp_def)
with that(1) have "fst (rep_nat_term x) < fst (rep_nat_term y)" by simp
hence "rep_nat_term x < rep_nat_term y" by (simp add: less_prod_def)
thus ?thesis by (rule less_term)
qed
have 5: False if "fst (rep_nat_term x) ≠ fst (rep_nat_term y)"
and "¬ lex_pp (fst (rep_nat_term x)) (fst (rep_nat_term y))" and "x < y" for x y
proof -
from that(2) have a: "lex_pp (fst (rep_nat_term y)) (fst (rep_nat_term x))" by (rule lex_pp_lin')
with that(1)[symmetric] have "y < x" by (rule 4)
also have "... < y" by fact
finally show False ..
qed
show ?thesis
by (intro ext, simp add: lex_comp lex_comp_aux_def comparator_of_def linorder_class.comparator_of_def lex.eq split: order.splits,
auto simp: lex_pp_refl comp_of_ord_def elim: 1 2 3 4 5)
qed
lemma full_component_zeroE: obtains x where "rep_nat_term x = (t, 0)"
proof -
from zero_component obtain x' where "snd (rep_nat_term x') = 0" ..
then obtain x where "rep_nat_term x = (t, 0)" by (rule full_componentE)
thus ?thesis ..
qed
end
lemma comparator_lex_comp: "comparator lex_comp"
unfolding lex_comp by (fact comparator_lex_comp_aux)
lemma nat_term_comp_lex_comp: "nat_term_comp lex_comp"
unfolding lex_comp by (fact nat_term_comp_lex_comp_aux)
lemma comparator_deg_comp:
assumes "comparator cmp"
shows "comparator (deg_comp cmp)"
unfolding deg_comp using comparator_of assms by (rule comparator_lexicographic)
lemma comparator_pot_comp:
assumes "comparator cmp"
shows "comparator (pot_comp cmp)"
unfolding pot_comp using comparator_of assms by (rule comparator_lexicographic)
lemma deg_comp_zero_min:
assumes "comparator cmp" and "snd (rep_nat_term u) = snd (rep_nat_term v)" and "fst (rep_nat_term u) = 0"
shows "deg_comp cmp u v ≠ Gt"
proof (simp add: deg_comp assms(3) comparator_of_def split: order.split, intro impI)
assume "fst (rep_nat_term v) = 0"
with assms(3) have "fst (rep_nat_term u) = fst (rep_nat_term v)" by simp
hence "rep_nat_term u = rep_nat_term v" using assms(2) by (rule prod_eqI)
hence "u = v" by (rule rep_nat_term_inj)
from assms(1) interpret c: comparator cmp .
show "cmp u v ≠ Gt" by (simp add: ‹u = v›)
qed
lemma deg_comp_pos:
assumes "cmp u v = Lt" and "fst (rep_nat_term u) = fst (rep_nat_term v)"
shows "deg_comp cmp u v = Lt"
by (simp add: deg_comp assms split: order.split)
lemma deg_comp_monotone:
assumes "cmp u v = Lt ⟹ cmp (splus t u) (splus t v) = Lt" and "deg_comp cmp u v = Lt"
shows "deg_comp cmp (splus t u) (splus t v) = Lt"
using assms(2) by (auto simp: deg_comp splus_term pprod.splus_def comparator_of_def deg_pp_plus
split: order.splits if_splits intro: assms(1))
lemma pot_comp_zero_min:
assumes "cmp u v ≠ Gt" and "snd (rep_nat_term u) = snd (rep_nat_term v)"
shows "pot_comp cmp u v ≠ Gt"
by (simp add: pot_comp comparator_of_def assms split: order.split)
lemma pot_comp_pos:
assumes "snd (rep_nat_term u) < snd (rep_nat_term v)"
shows "pot_comp cmp u v = Lt"
by (simp add: pot_comp comparator_of_def assms split: order.split)
lemma pot_comp_monotone:
assumes "cmp u v = Lt ⟹ cmp (splus t u) (splus t v) = Lt" and "pot_comp cmp u v = Lt"
shows "pot_comp cmp (splus t u) (splus t v) = Lt"
using assms(2) by (auto simp: pot_comp splus_term pprod.splus_def comparator_of_def deg_pp_plus
split: order.splits if_splits intro: assms(1))
lemma deg_comp_cong:
assumes "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v)) ⟹ to1 u v = to2 u v"
shows "deg_comp to1 u v = deg_comp to2 u v"
using assms by (simp add: deg_comp comparator_of_def split: order.split)
lemma pot_comp_cong:
assumes "snd (rep_nat_term u) = snd (rep_nat_term v) ⟹ to1 u v = to2 u v"
shows "pot_comp to1 u v = pot_comp to2 u v"
using assms by (simp add: pot_comp comparator_of_def split: order.split)
instantiation pp :: (nat, nat) nat_pp_compare
begin
definition rep_nat_pp_pp :: "('a, 'b) pp ⇒ (nat, nat) pp"
where rep_nat_pp_pp_def [code del]: "rep_nat_pp_pp x = pp_of_fun (λn::nat. rep_nat (lookup_pp x (abs_nat n)))"
definition abs_nat_pp_pp :: "(nat, nat) pp ⇒ ('a, 'b) pp"
where abs_nat_pp_pp_def [code del]: "abs_nat_pp_pp t = pp_of_fun (λn::'a. abs_nat (lookup_pp t (rep_nat n)))"
definition lex_comp'_pp :: "('a, 'b) pp comparator"
where lex_comp'_pp_def [code del]: "lex_comp'_pp = comp_of_ord lex_pp"
definition deg'_pp :: "('a, 'b) pp ⇒ nat"
where "deg'_pp x = rep_nat (deg_pp x)"
lemma lookup_rep_nat_pp_pp:
"lookup_pp (rep_nat_pp t) = (λn::nat. rep_nat (lookup_pp t (abs_nat n)))"
unfolding rep_nat_pp_pp_def
proof (rule lookup_pp_of_fun)
have "{n. lookup_pp t (abs_nat n) ≠ 0} ⊆ rep_nat ` {x. lookup_pp t x ≠ 0}"
proof
fix n
have "n = rep_nat (abs_nat n)" by (simp only: nat_class.abs_inverse)
assume "n ∈ {n. lookup_pp t (abs_nat n) ≠ 0}"
hence "abs_nat n ∈ {x. lookup_pp t x ≠ 0}" by simp
with ‹n = rep_nat (abs_nat n)› show "n ∈ rep_nat ` {x. lookup_pp t x ≠ 0}" ..
qed
also have "finite ..." by (rule finite_imageI, transfer, simp)
also (finite_subset) have "{n. lookup_pp t (abs_nat n) ≠ 0} = {n. rep_nat (lookup_pp t (abs_nat n)) ≠ 0}"
by (metis rep_inj rep_zero)
finally show "finite {x. rep_nat (lookup_pp t (abs_nat x)) ≠ 0}" .
qed
lemma lookup_abs_nat_pp_pp:
"lookup_pp (abs_nat_pp t) = (λn::'a. abs_nat (lookup_pp t (rep_nat n)))"
unfolding abs_nat_pp_pp_def
proof (rule lookup_pp_of_fun)
have "{n::'a. lookup_pp t (rep_nat n) ≠ 0} ⊆ abs_nat ` {x. lookup_pp t x ≠ 0}"
proof
fix n :: 'a
have "n = abs_nat (rep_nat n)" by (simp only: nat_class.rep_inverse)
assume "n ∈ {n. lookup_pp t (rep_nat n) ≠ 0}"
hence "rep_nat n ∈ {x. lookup_pp t x ≠ 0}" by simp
with ‹n = abs_nat (rep_nat n)› show "n ∈ abs_nat ` {x. lookup_pp t x ≠ 0}" ..
qed
also have "finite ..." by (rule finite_imageI, transfer, simp)
also (finite_subset) have "{n::'a. lookup_pp t (rep_nat n) ≠ 0} = {n. abs_nat (lookup_pp t (rep_nat n)) ≠ 0}"
by (metis abs_inverse abs_zero)
finally show "finite {n::'a. abs_nat (lookup_pp t (rep_nat n)) ≠ 0}" .
qed
lemma keys_rep_nat_pp_pp: "keys_pp (rep_nat_pp t) = rep_nat ` keys_pp t"
by (rule set_eqI,
simp add: keys_pp_iff lookup_rep_nat_pp_pp image_iff Bex_def ex_iff_abs[where 'a='a] rep_zero_iff del: neq0_conv)
lemma rep_nat_pp_pp_inverse: "abs_nat_pp (rep_nat_pp x) = x" for x::"('a, 'b) pp"
by (rule pp_eqI, simp add: lookup_abs_nat_pp_pp lookup_rep_nat_pp_pp)
lemma abs_nat_pp_pp_inverse: "rep_nat_pp ((abs_nat_pp t)::('a, 'b) pp) = t"
by (rule pp_eqI, simp add: lookup_abs_nat_pp_pp lookup_rep_nat_pp_pp)
corollary rep_nat_pp_pp_inj:
fixes x y :: "('a, 'b) pp"
assumes "rep_nat_pp x = rep_nat_pp y"
shows "x = y"
by (metis (no_types) rep_nat_pp_pp_inverse assms)
corollary rep_nat_pp_pp_eq_iff: "(rep_nat_pp x = rep_nat_pp y) ⟷ (x = y)" for x y :: "('a, 'b) pp"
by (auto elim: rep_nat_pp_pp_inj)
lemma lex_rep_nat_pp: "lex_pp (rep_nat_pp x) (rep_nat_pp y) ⟷ lex_pp x y"
by (simp add: lex_pp_alt rep_nat_pp_pp_eq_iff lookup_rep_nat_pp_pp rep_eq_iff
ord_iff[symmetric] ex_iff_abs[where 'a='a] all_iff_abs')
corollary lex_comp'_pp: "lex_comp' x y = comp_of_ord lex_pp (rep_nat_pp x) (rep_nat_pp y)" for x y :: "('a, 'b) pp"
by (simp add: lex_comp'_pp_def comp_of_ord_def rep_nat_pp_pp_eq_iff lex_rep_nat_pp)
corollary le_pp_pp: "rep_nat_pp x ≤ rep_nat_pp y ⟹ x ≤ y" for x y :: "('a, 'b) pp"
by (simp only: less_eq_pp_def lex_rep_nat_pp)
lemma deg_rep_nat_pp: "deg_pp (rep_nat_pp t) = rep_nat (deg_pp t)" for t :: "('a, 'b) pp"
proof -
have "keys_pp (rep_nat_pp t) = rep_nat ` keys_pp t"
by (rule set_eqI, simp add: keys_pp_iff image_iff lookup_rep_nat_pp_pp Bex_def ex_iff_abs[where 'a='a] rep_zero_iff del: neq0_conv)
hence "deg_pp (rep_nat_pp t) = sum (lookup_pp (rep_nat_pp t)) (rep_nat ` keys_pp t)"
by (simp add: deg_pp_alt)
also have "... = sum (lookup_pp (rep_nat_pp t) ∘ rep_nat) (keys_pp t)"
by (rule sum.reindex, rule inj_onI, elim rep_inj)
also have "... = sum (rep_nat ∘ (lookup_pp t)) (keys_pp t)"
by (simp add: lookup_rep_nat_pp_pp)
also have "... = rep_nat (deg_pp t)" by (simp only: deg_pp_alt sum_rep)
finally show ?thesis .
qed
corollary deg'_pp: "deg' t = deg_pp (rep_nat_pp t)" for t :: "('a, 'b) pp"
by (simp add: deg'_pp_def deg_rep_nat_pp)
lemma zero_pp_pp: "rep_nat_pp (0::('a, 'b) pp) = 0"
by (rule pp_eqI, simp add: lookup_rep_nat_pp_pp)
lemma plus_pp_pp: "rep_nat_pp (x + y) = rep_nat_pp x + rep_nat_pp y"
for x y :: "('a, 'b) pp"
by (rule pp_eqI, simp add: lookup_rep_nat_pp_pp lookup_plus_pp rep_plus)
instance
apply intro_classes
subgoal by (fact rep_nat_pp_pp_inverse)
subgoal by (fact abs_nat_pp_pp_inverse)
subgoal by (fact lex_comp'_pp)
subgoal by (fact deg'_pp)
subgoal by (rule le_pp_pp)
subgoal by (fact zero_pp_pp)
subgoal by (fact plus_pp_pp)
done
end
instantiation pp :: (nat, nat) nat_term
begin
definition rep_nat_term_pp :: "('a, 'b) pp ⇒ (nat, nat) pp × nat"
where rep_nat_term_pp_def [code del]: "rep_nat_term_pp t = (rep_nat_pp t, 0)"
definition splus_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ ('a, 'b) pp"
where splus_pp_def [code del]: "splus_pp = (+)"
instance proof
fix x y :: "('a, 'b) pp"
assume "rep_nat_term x = rep_nat_term y"
hence "rep_nat_pp x = rep_nat_pp y" by (simp add: rep_nat_term_pp_def)
thus "x = y" by (rule rep_nat_pp_pp_inj)
next
fix x::"('a, 'b) pp" and i t
assume "snd (rep_nat_term x) = i"
hence "i = 0" by (simp add: rep_nat_term_pp_def)
show "∃y::('a, 'b) pp. rep_nat_term y = (t, i)" unfolding ‹i = 0›
proof
show "rep_nat_term ((abs_nat_pp t)::('a, 'b) pp) = (t, 0)" by (simp add: rep_nat_term_pp_def)
qed
next
fix x y :: "('a, 'b) pp"
show "rep_nat_term (splus x y) = pprod.splus (fst (rep_nat_term x)) (rep_nat_term y)"
by (simp add: splus_pp_def rep_nat_term_pp_def pprod.splus_def plus_pp_pp)
qed
end
instantiation pp :: (nat, nat) nat_term_compare
begin
definition is_scalar_pp :: "('a, 'b) pp itself ⇒ bool"
where is_scalar_pp_def [code_unfold]: "is_scalar_pp = (λ_. True)"
definition lex_comp_pp :: "('a, 'b) pp comparator"
where lex_comp_pp_def [code_unfold]: "lex_comp_pp = lex_comp'"
definition deg_comp_pp :: "('a, 'b) pp comparator ⇒ ('a, 'b) pp comparator"
where deg_comp_pp_def: "deg_comp_pp cmp = (λx y. case comparator_of (deg_pp x) (deg_pp y) of Eq ⇒ cmp x y | val ⇒ val)"
definition pot_comp_pp :: "('a, 'b) pp comparator ⇒ ('a, 'b) pp comparator"
where pot_comp_pp_def [code_unfold]: "pot_comp_pp = (λcmp. cmp)"
instance proof
show "∃x::('a, 'b) pp. snd (rep_nat_term x) = 0"
proof
show "snd (rep_nat_term (0::('a, 'b) pp)) = 0" by (simp add: rep_nat_term_pp_def)
qed
next
show "is_scalar = (λ_::('a, 'b) pp itself. ∀x::('a, 'b) pp. snd (rep_nat_term x) = 0)"
by (simp add: is_scalar_pp_def rep_nat_term_pp_def)
next
show "lex_comp = (lex_comp_aux::('a, 'b) pp comparator)"
by (auto simp: lex_comp_pp_def lex_comp_aux_def rep_nat_term_pp_def lex_comp'_pp split: order.split intro!: ext)
next
fix cmp :: "('a, 'b) pp comparator"
show "deg_comp cmp =
(λx y. case comparator_of (deg_pp (fst (rep_nat_term x))) (deg_pp (fst (rep_nat_term y))) of Eq ⇒ cmp x y
| Lt ⇒ Lt | Gt ⇒ Gt)"
by (simp add: rep_nat_term_pp_def deg_comp_pp_def deg_rep_nat_pp comparator_of_rep)
next
fix cmp :: "('a, 'b) pp comparator"
show "pot_comp cmp =
(λx y. case comparator_of (snd (rep_nat_term x)) (snd (rep_nat_term y)) of Eq ⇒ cmp x y | Lt ⇒ Lt | Gt ⇒ Gt)"
by (simp add: rep_nat_term_pp_def pot_comp_pp_def)
next
fix x y :: "('a, 'b) pp"
assume "rep_nat_term x ≤ rep_nat_term y"
hence "rep_nat_pp x ≤ rep_nat_pp y" by (auto simp: rep_nat_term_pp_def)
thus "x ≤ y" by (rule le_pp_pp)
qed
end
instance pp :: (nat, nat) nat_pp_term
proof
show "rep_nat_term (0::('a, 'b) pp) = (0, 0)"
by (simp add: rep_nat_term_pp_def) (metis deg_pp_eq_0_iff deg_rep_nat_pp rep_zero)
next
show "splus = ((+)::('a, 'b) pp ⇒ _)" by (simp add: splus_pp_def)
qed
instantiation prod :: ("{nat_pp_compare, comm_powerprod}", nat) nat_term
begin
definition rep_nat_term_prod :: "('a × 'b) ⇒ ((nat, nat) pp × nat)"
where rep_nat_term_prod_def [code del]: "rep_nat_term_prod u = (rep_nat_pp (fst u), rep_nat (snd u))"
definition splus_prod :: "('a × 'b) ⇒ ('a × 'b) ⇒ ('a × 'b)"
where splus_prod_def [code del]: "splus_prod t u = pprod.splus (fst t) u"
instance proof
fix x y :: "'a × 'b"
assume "rep_nat_term x = rep_nat_term y"
hence 1: "rep_nat_pp (fst x) = rep_nat_pp (fst y)" and 2: "rep_nat (snd x) = rep_nat (snd y)"
by (simp_all add: rep_nat_term_prod_def)
from 1 have "fst x = fst y" by (rule rep_nat_pp_inj)
moreover from 2 have "snd x = snd y" by (rule rep_inj)
ultimately show "x = y" by (rule prod_eqI)
next
fix i t
show "∃y::'a × 'b. rep_nat_term y = (t, i)"
proof
show "rep_nat_term (abs_nat_pp t, abs_nat i) = (t, i)" by (simp add: rep_nat_term_prod_def)
qed
next
fix x y :: "'a × 'b"
show "rep_nat_term (splus x y) = pprod.splus (fst (rep_nat_term x)) (rep_nat_term y)"
by (simp add: splus_prod_def rep_nat_term_prod_def pprod.splus_def plus_pp)
qed
end
instantiation prod :: ("{nat_pp_compare, comm_powerprod}", nat) nat_term_compare
begin
definition is_scalar_prod :: "('a × 'b) itself ⇒ bool"
where is_scalar_prod_def [code_unfold]: "is_scalar_prod = (λ_. False)"
definition lex_comp_prod :: "('a × 'b) comparator"
where "lex_comp_prod = (λu v. case lex_comp' (fst u) (fst v) of Eq ⇒ comparator_of (snd u) (snd v) | val ⇒ val)"
definition deg_comp_prod :: "('a × 'b) comparator ⇒ ('a × 'b) comparator"
where deg_comp_prod_def: "deg_comp_prod cmp = (λx y. case comparator_of (deg' (fst x)) (deg' (fst y)) of Eq ⇒ cmp x y | val ⇒ val)"
definition pot_comp_prod :: "('a × 'b) comparator ⇒ ('a × 'b) comparator"
where "pot_comp_prod cmp = (λu v. case comparator_of (snd u) (snd v) of Eq ⇒ cmp u v | val ⇒ val)"
instance proof
show "∃x::'a × 'b. snd (rep_nat_term x) = 0"
proof
show "snd (rep_nat_term (abs_nat_pp 0, 0)) = 0" by (simp add: rep_nat_term_prod_def)
qed
next
have "¬ (∀a. rep_nat (a::'b) = 0)"
proof
assume "∀a. rep_nat (a::'b) = 0"
hence "rep_nat ((abs_nat 1)::'b) = 0" by blast
hence "((abs_nat 1)::'b) = 0" by (simp only: rep_zero_iff)
hence "(1::nat) = 0" by (metis abs_inj abs_zero)
thus False by simp
qed
thus "is_scalar = (λ_::('a × 'b) itself. ∀x. snd (rep_nat_term (x::'a × 'b)) = 0)"
by (auto simp add: is_scalar_prod_def rep_nat_term_prod_def intro!: ext)
next
show "lex_comp = (lex_comp_aux::('a × 'b) comparator)"
by (auto simp: lex_comp_prod_def lex_comp_aux_def rep_nat_term_prod_def lex_comp' comparator_of_rep split: order.split intro!: ext)
next
fix cmp :: "('a × 'b) comparator"
show "deg_comp cmp =
(λx y. case comparator_of (deg_pp (fst (rep_nat_term x))) (deg_pp (fst (rep_nat_term y))) of Eq ⇒ cmp x y
| Lt ⇒ Lt | Gt ⇒ Gt)"
by (simp add: rep_nat_term_prod_def deg_comp_prod_def deg')
next
fix cmp :: "('a × 'b) comparator"
show "pot_comp cmp =
(λx y. case comparator_of (snd (rep_nat_term x)) (snd (rep_nat_term y)) of Eq ⇒ cmp x y | Lt ⇒ Lt | Gt ⇒ Gt)"
by (simp add: rep_nat_term_prod_def pot_comp_prod_def comparator_of_rep)
next
fix x y :: "'a × 'b"
assume "rep_nat_term x ≤ rep_nat_term y"
hence "rep_nat_pp (fst x) < rep_nat_pp (fst y) ∨ (rep_nat_pp (fst x) ≤ rep_nat_pp (fst y) ∧ rep_nat (snd x) ≤ rep_nat (snd y))"
by (simp add: rep_nat_term_prod_def)
thus "x ≤ y" by (auto simp: less_eq_prod_def ord_iff[symmetric] intro: le_pp less_pp)
qed
end
lemmas [code del] = deg_pp.rep_eq plus_pp.abs_eq minus_pp.abs_eq
lemma rep_nat_pp_nat [code_unfold]: "(rep_nat_pp::(nat, nat) pp ⇒ (nat, nat) pp) = (λx. x)"
by (intro ext pp_eqI, simp add: lookup_rep_nat_pp_pp abs_nat_nat_def rep_nat_nat_def)
subsubsection ‹‹LEX›, ‹DRLEX›, ‹DEG› and ‹POT››
definition LEX :: "'a::nat_term_compare nat_term_order" where "LEX = Abs_nat_term_order lex_comp"
definition DRLEX :: "'a::nat_term_compare nat_term_order"
where "DRLEX = Abs_nat_term_order (deg_comp (pot_comp (λx y. lex_comp y x)))"
definition DEG :: "'a::nat_term_compare nat_term_order ⇒ 'a nat_term_order"
where "DEG to = Abs_nat_term_order (deg_comp (nat_term_compare to))"
definition POT :: "'a::nat_term_compare nat_term_order ⇒ 'a nat_term_order"
where "POT to = Abs_nat_term_order (pot_comp (nat_term_compare to))"
text ‹@{const DRLEX} must apply @{const pot_comp}, for otherwise it does not satisfy
the second condition of @{const nat_term_comp}.›
text ‹Instead of @{const DRLEX} one could also introduce another unary constructor ‹DEGREV›, analogous
to @{const DEG} and @{const POT}. Then, however, proving (in)equalities of the term orders gets
really messy (think of @{prop "DEG (POT to) = DEGREV (DEGREV to)"}, for instance).
So, we restrict the formalization to @{const DRLEX} only.›
abbreviation "DLEX ≡ DEG LEX"
code_datatype LEX DRLEX DEG POT
lemma nat_term_compare_LEX [code]: "nat_term_compare LEX = lex_comp"
unfolding LEX_def using comparator_lex_comp nat_term_comp_lex_comp
by (rule nat_term_compare_Abs_nat_term_order_id)
lemma nat_term_compare_DRLEX [code]: "nat_term_compare DRLEX = deg_comp (pot_comp (λx y. lex_comp y x))"
proof -
have cmp: "comparator (pot_comp (λx y. lex_comp y x))"
by (rule comparator_pot_comp, rule comparator_converse, fact comparator_lex_comp)
show ?thesis unfolding DRLEX_def
proof (rule nat_term_compare_Abs_nat_term_order_id)
from cmp show "comparator (deg_comp (pot_comp (λx y::'a. lex_comp y x)))"
by (rule comparator_deg_comp)
next
show "nat_term_comp (deg_comp (pot_comp (λx y::'a. lex_comp y x)))"
proof (rule nat_term_compI)
fix u v :: 'a
assume "snd (rep_nat_term u) = snd (rep_nat_term v)" and "fst (rep_nat_term u) = 0"
with cmp show "deg_comp (pot_comp (λx y::'a. lex_comp y x)) u v ≠ Gt"
by (rule deg_comp_zero_min)
next
fix u v :: 'a
assume "snd (rep_nat_term u) < snd (rep_nat_term v)"
hence "pot_comp (λx y. lex_comp y x) u v = Lt" by (rule pot_comp_pos)
moreover assume "fst (rep_nat_term u) = fst (rep_nat_term v)"
ultimately show "deg_comp (pot_comp (λx y. lex_comp y x)) u v = Lt" by (rule deg_comp_pos)
next
fix t u v :: 'a
have "pot_comp (λx y. lex_comp y x) (splus t u) (splus t v) = Lt"
if "pot_comp (λx y. lex_comp y x) u v = Lt" using _ that
proof (rule pot_comp_monotone)
assume "lex_comp v u = Lt"
with nat_term_comp_lex_comp show "lex_comp (splus t v) (splus t u) = Lt"
by (rule nat_term_compD3)
qed
moreover assume "deg_comp (pot_comp (λx y. lex_comp y x)) u v = Lt"
ultimately show "deg_comp (pot_comp (λx y. lex_comp y x)) (splus t u) (splus t v) = Lt"
by (rule deg_comp_monotone)
next
fix u v a b :: 'a
assume "fst (rep_nat_term v) = fst (rep_nat_term b)" and "fst (rep_nat_term u) = fst (rep_nat_term a)"
and "snd (rep_nat_term u) = snd (rep_nat_term v)" and "snd (rep_nat_term a) = snd (rep_nat_term b)"
moreover from comparator_lex_comp nat_term_comp_lex_comp this(1, 2) this(3, 4)[symmetric]
have "lex_comp v u = lex_comp b a" by (rule nat_term_compD4')
moreover assume "deg_comp (pot_comp (λx y. lex_comp y x)) a b = Lt"
ultimately show "deg_comp (pot_comp (λx y. lex_comp y x)) u v = Lt"
by (simp add: deg_comp pot_comp split: order.splits)
qed
qed
qed
lemma nat_term_compare_DEG [code]: "nat_term_compare (DEG to) = deg_comp (nat_term_compare to)"
unfolding DEG_def
proof (rule nat_term_compare_Abs_nat_term_order_id)
from comparator_nat_term_compare show "comparator (deg_comp (nat_term_compare to))"
by (rule comparator_deg_comp)
next
show "nat_term_comp (deg_comp (nat_term_compare to))"
proof (rule nat_term_compI)
fix u v :: 'a
assume "snd (rep_nat_term u) = snd (rep_nat_term v)" and "fst (rep_nat_term u) = 0"
with comparator_nat_term_compare show "deg_comp (nat_term_compare to) u v ≠ Gt"
by (rule deg_comp_zero_min)
next
fix u v :: 'a
assume a: "fst (rep_nat_term u) = fst (rep_nat_term v)" and "snd (rep_nat_term u) < snd (rep_nat_term v)"
with nat_term_comp_nat_term_compare have "nat_term_compare to u v = Lt" by (rule nat_term_compD2)
thus "deg_comp (nat_term_compare to) u v = Lt" using a by (rule deg_comp_pos)
next
fix t u v :: 'a
from nat_term_comp_nat_term_compare
have "nat_term_compare to u v = Lt ⟹ nat_term_compare to (splus t u) (splus t v) = Lt"
by (rule nat_term_compD3)
moreover assume "deg_comp (nat_term_compare to) u v = Lt"
ultimately show "deg_comp (nat_term_compare to) (splus t u) (splus t v) = Lt" by (rule deg_comp_monotone)
next
fix u v a b :: 'a
assume "fst (rep_nat_term u) = fst (rep_nat_term a)" and "fst (rep_nat_term v) = fst (rep_nat_term b)"
and "snd (rep_nat_term u) = snd (rep_nat_term v)" and "snd (rep_nat_term a) = snd (rep_nat_term b)"
moreover from comparator_nat_term_compare nat_term_comp_nat_term_compare this
have "nat_term_compare to u v = nat_term_compare to a b"
by (rule nat_term_compD4')
moreover assume "deg_comp (nat_term_compare to) a b = Lt"
ultimately show "deg_comp (nat_term_compare to) u v = Lt"
by (simp add: deg_comp split: order.splits)
qed
qed
lemma nat_term_compare_POT [code]: "nat_term_compare (POT to) = pot_comp (nat_term_compare to)"
unfolding POT_def
proof (rule nat_term_compare_Abs_nat_term_order_id)
from comparator_nat_term_compare show "comparator (pot_comp (nat_term_compare to))"
by (rule comparator_pot_comp)
next
show "nat_term_comp (pot_comp (nat_term_compare to))"
proof (rule nat_term_compI)
fix u v :: 'a
assume a: "snd (rep_nat_term u) = snd (rep_nat_term v)" and "fst (rep_nat_term u) = 0"
with nat_term_comp_nat_term_compare have "nat_term_compare to u v ≠ Gt" by (rule nat_term_compD1)
thus "pot_comp (nat_term_compare to) u v ≠ Gt" using a by (rule pot_comp_zero_min)
next
fix u v :: 'a
assume "snd (rep_nat_term u) < snd (rep_nat_term v)"
thus "pot_comp (nat_term_compare to) u v = Lt" by (rule pot_comp_pos)
next
fix t u v :: 'a
from nat_term_comp_nat_term_compare
have "nat_term_compare to u v = Lt ⟹ nat_term_compare to (splus t u) (splus t v) = Lt"
by (rule nat_term_compD3)
moreover assume "pot_comp (nat_term_compare to) u v = Lt"
ultimately show "pot_comp (nat_term_compare to) (splus t u) (splus t v) = Lt" by (rule pot_comp_monotone)
next
fix u v a b :: 'a
assume "fst (rep_nat_term u) = fst (rep_nat_term a)" and "fst (rep_nat_term v) = fst (rep_nat_term b)"
and "snd (rep_nat_term u) = snd (rep_nat_term v)" and "snd (rep_nat_term a) = snd (rep_nat_term b)"
moreover from comparator_nat_term_compare nat_term_comp_nat_term_compare this
have "nat_term_compare to u v = nat_term_compare to a b"
by (rule nat_term_compD4')
moreover assume "pot_comp (nat_term_compare to) a b = Lt"
ultimately show "pot_comp (nat_term_compare to) u v = Lt"
by (simp add: pot_comp split: order.splits)
qed
qed
lemma nat_term_compare_POT_DRLEX [code]:
"nat_term_compare (POT DRLEX) = pot_comp (deg_comp (λx y. lex_comp y x))"
unfolding nat_term_compare_POT nat_term_compare_DRLEX
by (intro ext pot_comp_cong deg_comp_cong, simp add: pot_comp)
lemma compute_lex_pp [code]: "lex_pp p q = (lex_comp' p q ≠ Gt)"
by (simp add: lex_comp'_pp_def comp_of_ord_def)
lemma compute_dlex_pp [code]: "dlex_pp p q = (deg_comp lex_comp' p q ≠ Gt)"
by (simp add: deg_comp_pp_def dlex_pp_alt compute_lex_pp comparator_of_def)
lemma compute_drlex_pp [code]: "drlex_pp p q = (deg_comp (λx y. lex_comp' y x) p q ≠ Gt)"
by (simp add: deg_comp_pp_def drlex_pp_alt compute_lex_pp comparator_of_def)
lemma nat_pp_order_of_le_nat_pp [code]: "nat_term_order_of_le = LEX"
by (simp add: nat_term_order_of_le_def LEX_def lex_comp_alt)
subsubsection ‹Equality of Term Orders›
definition nat_term_order_eq :: "'a nat_term_order ⇒ 'a::nat_term_compare nat_term_order ⇒ bool ⇒ bool ⇒ bool"
where nat_term_order_eq_def [code del]:
"nat_term_order_eq to1 to2 dg ps =
(∀u v. (dg ⟶ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))) ⟶
(ps ⟶ snd (rep_nat_term u) = snd (rep_nat_term v)) ⟶
nat_term_compare to1 u v = nat_term_compare to2 u v)"
lemma nat_term_order_eqI:
assumes "⋀u v. (dg ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))) ⟹
(ps ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)) ⟹
nat_term_compare to1 u v = nat_term_compare to2 u v"
shows "nat_term_order_eq to1 to2 dg ps"
unfolding nat_term_order_eq_def using assms by blast
lemma nat_term_order_eqD:
assumes "nat_term_order_eq to1 to2 dg ps"
and "dg ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
and "ps ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
shows "nat_term_compare to1 u v = nat_term_compare to2 u v"
using assms unfolding nat_term_order_eq_def by blast
lemma nat_term_order_eq_sym: "nat_term_order_eq to1 to2 dg ps ⟷ nat_term_order_eq to2 to1 dg ps"
by (auto simp: nat_term_order_eq_def)
lemma nat_term_order_eq_DEG_dg:
"nat_term_order_eq (DEG to1) to2 True ps ⟷ nat_term_order_eq to1 to2 True ps"
by (auto simp: nat_term_order_eq_def nat_term_compare_DEG deg_comp)
lemma nat_term_order_eq_DEG_dg':
"nat_term_order_eq to1 (DEG to2) True ps ⟷ nat_term_order_eq to1 to2 True ps"
by (simp add: nat_term_order_eq_sym[of to1] nat_term_order_eq_DEG_dg)
lemma nat_term_order_eq_POT_ps:
assumes "ps ∨ is_scalar TYPE('a::nat_term_compare)"
shows "nat_term_order_eq (POT (to1::'a nat_term_order)) to2 dg ps ⟷ nat_term_order_eq to1 to2 dg ps"
using assms
proof
assume "ps"
thus ?thesis by (auto simp: nat_term_order_eq_def nat_term_compare_POT pot_comp)
next
assume "is_scalar TYPE('a)"
hence "snd (rep_nat_term x) = 0" for x::'a by (simp add: is_scalar)
thus ?thesis by (auto simp: nat_term_order_eq_def nat_term_compare_POT pot_comp)
qed
lemma nat_term_order_eq_POT_ps':
assumes "ps ∨ is_scalar TYPE('a::nat_term_compare)"
shows "nat_term_order_eq to1 (POT (to2::'a nat_term_order)) dg ps ⟷ nat_term_order_eq to1 to2 dg ps"
using assms by (simp add: nat_term_order_eq_sym[of to1] nat_term_order_eq_POT_ps)
lemma snd_rep_nat_term_eqI:
assumes "ps ∨ is_scalar TYPE('a::nat_term_compare)" and "ps ⟹ snd (rep_nat_term (u::'a)) = snd (rep_nat_term (v::'a))"
shows "snd (rep_nat_term u) = snd (rep_nat_term v)"
using assms(1)
proof
assume "is_scalar TYPE('a)"
thus ?thesis by (simp add: is_scalar)
qed (fact assms(2))
definition of_exps :: "nat ⇒ nat ⇒ nat ⇒ 'a::nat_term_compare"
where "of_exps a b i =
(THE u. rep_nat_term u = (pp_of_fun (λx. if x = 0 then a else if x = 1 then b else 0),
if (∃v::'a. snd (rep_nat_term v) = i) then i else 0))"
text ‹@{const of_exps} is an auxiliary function needed for proving the equalities of the various
term orders.›
lemma rep_nat_term_of_exps:
"rep_nat_term ((of_exps a b i)::'a::nat_term_compare) =
(pp_of_fun (λx::nat. if x = 0 then a else if x = 1 then b else 0), if (∃y::'a. snd (rep_nat_term y) = i) then i else 0)"
proof (cases "∃y::'a. snd (rep_nat_term y) = i")
case True
then obtain y::'a where "snd (rep_nat_term y) = i" ..
then obtain u::'a where u: "rep_nat_term u = (pp_of_fun (λx::nat. if x = 0 then a else if x = 1 then b else 0), i)"
by (rule full_componentE)
from True have eq: "(if ∃y::'a. snd (rep_nat_term y) = i then i else 0) = i" by simp
show ?thesis unfolding of_exps_def eq
proof (rule theI)
fix v :: 'a
assume "rep_nat_term v = (pp_of_fun (λx::nat. if x = 0 then a else if x = 1 then b else 0), i)"
thus "v = u" unfolding u[symmetric] by (rule rep_nat_term_inj)
qed (fact u)
next
case False
hence eq: "(if ∃y::'a. snd (rep_nat_term y) = i then i else 0) = 0" by simp
obtain u::'a where u: "rep_nat_term u = (pp_of_fun (λx::nat. if x = 0 then a else if x = 1 then b else 0), 0)"
by (rule full_component_zeroE)
show ?thesis unfolding of_exps_def eq
proof (rule theI)
fix v :: 'a
assume "rep_nat_term v = (pp_of_fun (λx::nat. if x = 0 then a else if x = 1 then b else 0), 0)"
thus "v = u" unfolding u[symmetric] by (rule rep_nat_term_inj)
qed (fact u)
qed
lemma lookup_pp_of_exps:
"lookup_pp (fst (rep_nat_term (of_exps a b i))) = (λx. if x = 0 then a else if x = 1 then b else 0)"
unfolding rep_nat_term_of_exps fst_conv
proof (rule lookup_pp_of_fun)
have "{x. (if x = 0 then a else if x = 1 then b else 0) ≠ 0} ⊆ {0, 1}"
by (rule, simp split: if_split_asm)
also have "finite ..." by simp
finally(finite_subset) show "finite {x. (if x = 0 then a else if x = 1 then b else 0) ≠ 0}" .
qed
lemma keys_pp_of_exps: "keys_pp (fst (rep_nat_term (of_exps a b i))) ⊆ {0, 1}"
by (rule, simp add: keys_pp_iff lookup_pp_of_exps split: if_split_asm)
lemma deg_pp_of_exps [simp]: "deg_pp (fst (rep_nat_term ((of_exps a b i)::'a::nat_term_compare))) = a + b"
proof -
let ?u = "(of_exps a b i)::'a"
have "sum (lookup_pp (fst (rep_nat_term ?u))) (keys_pp (fst (rep_nat_term ?u))) =
sum (lookup_pp (fst (rep_nat_term ?u))) {0, 1}"
proof (rule sum.mono_neutral_left, simp, fact keys_pp_of_exps, intro ballI)
fix x
assume "x ∈ {0, 1} - keys_pp (fst (rep_nat_term ?u))"
thus "lookup_pp (fst (rep_nat_term ?u)) x = 0" by (simp add: keys_pp_iff)
qed
also have "... = a + b" by (simp add: lookup_pp_of_exps)
finally show ?thesis by (simp only: deg_pp_alt)
qed
lemma snd_of_exps:
assumes "snd (rep_nat_term (x::'a)) = i"
shows "snd (rep_nat_term ((of_exps a b i)::'a::nat_term_compare)) = i"
proof -
from assms have "∃x::'a. snd (rep_nat_term (x::'a)) = i" ..
thus ?thesis by (simp add: rep_nat_term_of_exps)
qed
lemma snd_of_exps_zero [simp]: "snd (rep_nat_term ((of_exps a b 0)::'a::nat_term_compare)) = 0"
proof -
from zero_component obtain x::'a where "snd (rep_nat_term (x::'a)) = 0" ..
thus ?thesis by (rule snd_of_exps)
qed
lemma eq_of_exps:
"(fst (rep_nat_term (of_exps a1 b1 i)) = fst (rep_nat_term (of_exps a2 b2 j))) ⟷ (a1 = a2 ∧ b1 = b2)"
proof -
have "a1 = a2 ∧ b1 = b2"
if "(λx::nat. if x = 0 then a1 else if x = 1 then b1 else 0) = (λx. if x = 0 then a2 else if x = 1 then b2 else 0)"
proof
from fun_cong[OF that, of 0] show "a1 = a2" by simp
next
from fun_cong[OF that, of 1] show "b1 = b2" by simp
qed
thus ?thesis by (auto simp: pp_eq_iff lookup_pp_of_exps)
qed
lemma lex_pp_of_exps:
"lex_pp (fst (rep_nat_term ((of_exps a1 b1 i)::'a))) (fst (rep_nat_term ((of_exps a2 b2 j)::'a::nat_term_compare))) ⟷
(a1 < a2 ∨ (a1 = a2 ∧ b1 ≤ b2))" (is "?L ⟷ ?R")
proof -
let ?u = "fst (rep_nat_term ((of_exps a1 b1 i)::'a))"
let ?v = "fst (rep_nat_term ((of_exps a2 b2 j)::'a))"
show ?thesis
proof
assume ?L
hence "?u = ?v ∨ (∃x. lookup_pp ?u x < lookup_pp ?v x ∧ (∀y<x. lookup_pp ?u y = lookup_pp ?v y))"
by (simp only: lex_pp_alt)
thus ?R
proof
assume "?u = ?v"
thus ?thesis by (simp add: eq_of_exps)
next
assume "∃x. lookup_pp ?u x < lookup_pp ?v x ∧ (∀y<x. lookup_pp ?u y = lookup_pp ?v y)"
then obtain x where 1: "lookup_pp ?u x < lookup_pp ?v x" and 2: "⋀y. y < x ⟹ lookup_pp ?u y = lookup_pp ?v y"
by auto
from 1 have "lookup_pp ?v x ≠ 0" by simp
hence "x ∈ keys_pp ?v" by (simp add: keys_pp_iff)
also have "... ⊆ {0, 1}" by (fact keys_pp_of_exps)
finally have "x = 0 ∨ x = 1" by simp
thus ?thesis
proof
assume "x = 0"
from 1 show ?thesis by (simp add: lookup_pp_of_exps ‹x = 0›)
next
assume "x = 1"
hence "0 < x" by simp
hence "lookup_pp ?u 0 = lookup_pp ?v 0" by (rule 2)
hence "a1 = a2" by (simp add: lookup_pp_of_exps)
from 1 show ?thesis by (simp add: lookup_pp_of_exps ‹x = 1› ‹a1 = a2›)
qed
qed
next
assume ?R
thus ?L
proof
assume "a1 < a2"
show ?thesis unfolding lex_pp_alt
proof (intro disjI2 exI conjI allI impI)
from ‹a1 < a2› show "lookup_pp ?u 0 < lookup_pp ?v 0" by (simp add: lookup_pp_of_exps)
next
fix y::nat
assume "y < 0"
thus "lookup_pp ?u y = lookup_pp ?v y" by simp
qed
next
assume "a1 = a2 ∧ b1 ≤ b2"
hence "a1 = a2" and "b1 ≤ b2" by simp_all
from this(2) have "b1 < b2 ∨ b1 = b2" by auto
thus ?thesis
proof
assume "b1 < b2"
show ?thesis unfolding lex_pp_alt
proof (intro disjI2 exI conjI allI impI)
from ‹b1 < b2› show "lookup_pp ?u 1 < lookup_pp ?v 1" by (simp add: lookup_pp_of_exps)
next
fix y::nat
assume "y < 1"
hence "y = 0" by simp
show "lookup_pp ?u y = lookup_pp ?v y" by (simp add: lookup_pp_of_exps ‹y = 0› ‹a1 = a2›)
qed
next
assume "b1 = b2"
show ?thesis by (simp add: lex_pp_alt eq_of_exps ‹a1 = a2› ‹b1 = b2›)
qed
qed
qed
qed
lemma LEX_eq [code]:
"nat_term_order_eq LEX (LEX::'a nat_term_order) dg ps = True" (is ?thesis1)
"nat_term_order_eq LEX (DRLEX::'a nat_term_order) dg ps = False" (is ?thesis2)
"nat_term_order_eq LEX (DEG (to::'a nat_term_order)) dg ps =
(dg ∧ nat_term_order_eq LEX to dg ps)" (is ?thesis3)
"nat_term_order_eq LEX (POT (to::'a nat_term_order)) dg ps =
((ps ∨ is_scalar TYPE('a::nat_term_compare)) ∧ nat_term_order_eq LEX to dg ps)" (is ?thesis4)
proof -
show ?thesis1 by (simp add: nat_term_order_eq_def)
next
show ?thesis2
proof (intro iffI)
assume a: "nat_term_order_eq LEX (DRLEX::'a nat_term_order) dg ps"
let ?u = "(of_exps 0 1 0)::'a"
let ?v = "(of_exps 1 0 0)::'a"
have "nat_term_compare LEX ?u ?v = nat_term_compare DRLEX ?u ?v"
by (rule nat_term_order_eqD, fact a, simp_all)
thus False
by (simp add: nat_term_compare_LEX lex_comp lex_comp_aux_def nat_term_compare_DRLEX deg_comp
pot_comp comparator_of_def comp_of_ord_def lex_pp_of_exps eq_of_exps)
qed (rule FalseE)
next
show ?thesis3
proof (intro iffI)
assume a: "nat_term_order_eq LEX (DEG to) dg ps"
have dg
proof (rule ccontr)
assume "¬ dg"
let ?u = "(of_exps 0 2 0)::'a"
let ?v = "(of_exps 1 0 0)::'a"
have "nat_term_compare LEX ?u ?v = nat_term_compare (DEG to) ?u ?v"
by (rule nat_term_order_eqD, fact a, simp_all add: ‹¬ dg›)
thus False
by (simp add: nat_term_compare_LEX lex_comp lex_comp_aux_def nat_term_compare_DEG deg_comp
comparator_of_def comp_of_ord_def lex_pp_of_exps eq_of_exps)
qed
show "dg ∧ nat_term_order_eq LEX to dg ps"
proof (intro conjI ‹dg› nat_term_order_eqI)
fix u v :: 'a
assume 1: "dg ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
from ‹dg› have eq: "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))" by (rule 1)
assume "ps ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
with a 1 have "nat_term_compare LEX u v = nat_term_compare (DEG to) u v"
by (rule nat_term_order_eqD)
also have "... = nat_term_compare to u v" by (simp add: nat_term_compare_DEG deg_comp eq)
finally show "nat_term_compare LEX u v = nat_term_compare to u v" .
qed
next
assume "dg ∧ nat_term_order_eq LEX to dg ps"
hence dg and a: "nat_term_order_eq LEX to dg ps" by auto
show "nat_term_order_eq LEX (DEG to) dg ps"
proof (rule nat_term_order_eqI)
fix u v :: 'a
assume 1: "dg ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
from ‹dg› have eq: "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))" by (rule 1)
assume "ps ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
with a 1 have "nat_term_compare LEX u v = nat_term_compare to u v" by (rule nat_term_order_eqD)
also have "... = nat_term_compare (DEG to) u v" by (simp add: nat_term_compare_DEG deg_comp eq)
finally show "nat_term_compare LEX u v = nat_term_compare (DEG to) u v" .
qed
qed
next
show ?thesis4
proof (intro iffI)
assume a: "nat_term_order_eq LEX (POT to) dg ps"
have *: "ps ∨ is_scalar TYPE('a)"
proof (rule ccontr)
assume "¬ (ps ∨ is_scalar TYPE('a))"
hence "¬ ps" and "¬ is_scalar TYPE('a)" by simp_all
from this(2) obtain x::'a where "snd (rep_nat_term x) ≠ 0" unfolding is_scalar by auto
moreover define i::nat where "i = snd (rep_nat_term x)"
ultimately have "i ≠ 0" by simp
let ?u = "(of_exps 0 1 i)::'a"
let ?v = "(of_exps 1 0 0)::'a"
from i_def[symmetric] have eq: "snd (rep_nat_term ?u) = i" by (rule snd_of_exps)
have "nat_term_compare LEX ?u ?v = nat_term_compare (POT to) ?u ?v"
by (rule nat_term_order_eqD, fact a, simp_all add: ‹¬ ps›)
thus False
by (simp add: nat_term_compare_LEX lex_comp lex_comp_aux_def pot_comp nat_term_compare_POT
comparator_of_def comp_of_ord_def lex_pp_of_exps eq_of_exps eq ‹i ≠ 0› del: One_nat_def)
qed
show "(ps ∨ is_scalar TYPE('a)) ∧ nat_term_order_eq LEX to dg ps"
proof (intro conjI * nat_term_order_eqI)
fix u v :: 'a
assume 1: "dg ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
assume 2: "ps ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
with * have eq: "snd (rep_nat_term u) = snd (rep_nat_term v)" by (rule snd_rep_nat_term_eqI)
from a 1 2 have "nat_term_compare LEX u v = nat_term_compare (POT to) u v"
by (rule nat_term_order_eqD)
also have "... = nat_term_compare to u v" by (simp add: nat_term_compare_POT eq pot_comp)
finally show "nat_term_compare LEX u v = nat_term_compare to u v" .
qed
next
assume "(ps ∨ is_scalar TYPE('a)) ∧ nat_term_order_eq LEX to dg ps"
hence *: "ps ∨ is_scalar TYPE('a)" and a: "nat_term_order_eq LEX to dg ps" by auto
show "nat_term_order_eq LEX (POT to) dg ps"
proof (rule nat_term_order_eqI)
fix u v :: 'a
assume 1: "dg ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
assume 2: "ps ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
with * have eq: "snd (rep_nat_term u) = snd (rep_nat_term v)" by (rule snd_rep_nat_term_eqI)
from a 1 2 have "nat_term_compare LEX u v = nat_term_compare to u v" by (rule nat_term_order_eqD)
also have "... = nat_term_compare (POT to) u v" by (simp add: nat_term_compare_POT eq pot_comp)
finally show "nat_term_compare LEX u v = nat_term_compare (POT to) u v" .
qed
qed
qed
lemma DRLEX_eq [code]:
"nat_term_order_eq DRLEX (LEX::'a nat_term_order) dg ps = False" (is ?thesis1)
"nat_term_order_eq DRLEX DRLEX dg ps = True" (is ?thesis2)
"nat_term_order_eq DRLEX (DEG (to::'a nat_term_order)) dg ps =
nat_term_order_eq DRLEX to True ps" (is ?thesis3)
"nat_term_order_eq DRLEX (POT (to::'a nat_term_order)) dg ps =
((dg ∨ ps ∨ is_scalar TYPE('a::nat_term_compare)) ∧ nat_term_order_eq DRLEX to dg True)" (is ?thesis4)
proof -
from nat_term_order_eq_sym[of "DRLEX::'a nat_term_order"] show ?thesis1 by (simp only: LEX_eq)
next
show ?thesis2 by (simp add: nat_term_order_eq_def)
next
show ?thesis3
proof (intro iffI)
assume a: "nat_term_order_eq DRLEX (DEG to) dg ps"
show "nat_term_order_eq DRLEX to True ps"
proof (rule nat_term_order_eqI)
fix u v :: 'a
assume 1: "True ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
and "ps ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
with a have "nat_term_compare DRLEX u v = nat_term_compare (DEG to) u v"
by (rule nat_term_order_eqD, blast+)
also have "... = nat_term_compare to u v" by (simp add: nat_term_compare_DEG deg_comp 1)
finally show "nat_term_compare DRLEX u v = nat_term_compare to u v" .
qed
next
assume a: "nat_term_order_eq DRLEX to True ps"
show "nat_term_order_eq DRLEX (DEG to) dg ps"
proof (rule nat_term_order_eqI)
fix u v :: 'a
assume 1: "ps ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
show "nat_term_compare DRLEX u v = nat_term_compare (DEG to) u v"
proof (simp add: nat_term_compare_DRLEX nat_term_compare_DEG deg_comp comparator_of_def split: order.split, rule)
assume 2: "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
with a have "nat_term_compare DRLEX u v = nat_term_compare to u v"
using 1 by (rule nat_term_order_eqD)
thus "pot_comp (λx y. lex_comp y x) u v = nat_term_compare to u v"
by (simp add: nat_term_compare_DRLEX deg_comp 2)
qed
qed
qed
next
show ?thesis4
proof (intro iffI)
assume a: "nat_term_order_eq DRLEX (POT to) dg ps"
have *: "dg ∨ ps ∨ is_scalar TYPE('a)"
proof (rule ccontr)
assume "¬ (dg ∨ ps ∨ is_scalar TYPE('a))"
hence "¬ dg" and "¬ ps" and "¬ is_scalar TYPE('a)" by simp_all
from this(3) obtain x::'a where "snd (rep_nat_term x) ≠ 0" unfolding is_scalar by auto
moreover define i::nat where "i = snd (rep_nat_term x)"
ultimately have "i ≠ 0" by simp
let ?u = "(of_exps 1 0 i)::'a"
let ?v = "(of_exps 2 0 0)::'a"
from i_def[symmetric] have eq: "snd (rep_nat_term ?u) = i" by (rule snd_of_exps)
have "nat_term_compare DRLEX ?u ?v = nat_term_compare (POT to) ?u ?v"
by (rule nat_term_order_eqD, fact a, simp_all add: ‹¬ ps› ‹¬ dg›)
thus False
by (simp add: nat_term_compare_DRLEX deg_comp pot_comp nat_term_compare_POT
comparator_of_def eq ‹i ≠ 0› del: One_nat_def)
qed
show "(dg ∨ ps ∨ is_scalar TYPE('a)) ∧ nat_term_order_eq DRLEX to dg True"
proof (intro conjI * nat_term_order_eqI)
fix u v :: 'a
assume 1: "dg ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
assume 2: "True ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
from a 1 2 have "nat_term_compare DRLEX u v = nat_term_compare (POT to) u v"
by (rule nat_term_order_eqD, blast+)
also have "... = nat_term_compare to u v" by (simp add: nat_term_compare_POT 2 pot_comp)
finally show "nat_term_compare DRLEX u v = nat_term_compare to u v" .
qed
next
assume "(dg ∨ ps ∨ is_scalar TYPE('a)) ∧ nat_term_order_eq DRLEX to dg True"
hence disj: "dg ∨ ps ∨ is_scalar TYPE('a)" and a: "nat_term_order_eq DRLEX to dg True" by auto
show "nat_term_order_eq DRLEX (POT to) dg ps"
proof (rule nat_term_order_eqI)
fix u v :: 'a
assume 1: "dg ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
assume 2: "ps ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
from disj show "nat_term_compare DRLEX u v = nat_term_compare (POT to) u v"
proof
assume dg
hence eq1: "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))" by (rule 1)
show ?thesis
proof (simp add: nat_term_compare_DRLEX deg_comp eq1 nat_term_compare_POT pot_comp comparator_of_def split: order.split, rule)
assume eq2: "snd (rep_nat_term u) = snd (rep_nat_term v)"
with a 1 have "nat_term_compare DRLEX u v = nat_term_compare to u v" by (rule nat_term_order_eqD)
thus "lex_comp v u = nat_term_compare to u v"
by (simp add: nat_term_compare_DRLEX deg_comp eq1 pot_comp eq2)
qed
next
assume "ps ∨ is_scalar TYPE('a)"
hence eq: "snd (rep_nat_term u) = snd (rep_nat_term v)" using 2 by (rule snd_rep_nat_term_eqI)
with a 1 have "nat_term_compare DRLEX u v = nat_term_compare to u v" by (rule nat_term_order_eqD)
also have "... = nat_term_compare (POT to) u v" by (simp add: nat_term_compare_POT pot_comp eq)
finally show ?thesis .
qed
qed
qed
qed
lemma DEG_eq [code]:
"nat_term_order_eq (DEG to) (LEX::'a nat_term_order) dg ps = nat_term_order_eq LEX (DEG to) dg ps"
"nat_term_order_eq (DEG to) (DRLEX::'a nat_term_order) dg ps = nat_term_order_eq DRLEX (DEG to) dg ps"
"nat_term_order_eq (DEG to1) (DEG (to2::'a nat_term_order)) dg ps =
nat_term_order_eq to1 to2 True ps" (is ?thesis3)
"nat_term_order_eq (DEG to1) (POT (to2::'a nat_term_order)) dg ps =
(if dg then nat_term_order_eq to1 (POT to2) dg ps
else ((ps ∨ is_scalar TYPE('a::nat_term_compare)) ∧ nat_term_order_eq (DEG to1) to2 dg ps))" (is ?thesis4)
proof -
show ?thesis3
proof (rule iffI)
assume a: "nat_term_order_eq (DEG to1) (DEG to2) dg ps"
show "nat_term_order_eq to1 to2 True ps"
proof (rule nat_term_order_eqI)
fix u v :: 'a
assume b: "True ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
and "ps ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
with a have "nat_term_compare (DEG to1) u v = nat_term_compare (DEG to2) u v"
by (rule nat_term_order_eqD, blast+)
thus "nat_term_compare to1 u v = nat_term_compare to2 u v"
by (simp add: nat_term_compare_DEG deg_comp comparator_of_def b)
qed
next
assume a: "nat_term_order_eq to1 to2 True ps"
show "nat_term_order_eq (DEG to1) (DEG to2) dg ps"
proof (rule nat_term_order_eqI)
fix u v :: 'a
assume b: "ps ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
show "nat_term_compare (DEG to1) u v = nat_term_compare (DEG to2) u v"
proof (simp add: nat_term_compare_DEG deg_comp comparator_of_def split: order.split, rule impI)
assume "deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
with a show "nat_term_compare to1 u v = nat_term_compare to2 u v" using b by (rule nat_term_order_eqD)
qed
qed
qed
next
show ?thesis4
proof (simp add: nat_term_order_eq_DEG_dg split: if_split, intro impI)
show "nat_term_order_eq (DEG to1) (POT to2) False ps =
((ps ∨ is_scalar TYPE('a)) ∧ nat_term_order_eq (DEG to1) to2 False ps)"
proof (intro iffI)
assume a: "nat_term_order_eq (DEG to1) (POT to2) False ps"
have *: "ps ∨ is_scalar TYPE('a)"
proof (rule ccontr)
assume "¬ (ps ∨ is_scalar TYPE('a))"
hence "¬ ps" and "¬ is_scalar TYPE('a)" by simp_all
from this(2) obtain x::'a where "snd (rep_nat_term x) ≠ 0" unfolding is_scalar by auto
moreover define i::nat where "i = snd (rep_nat_term x)"
ultimately have "i ≠ 0" by simp
let ?u = "(of_exps 1 0 i)::'a"
let ?v = "(of_exps 2 0 0)::'a"
from i_def[symmetric] have eq: "snd (rep_nat_term ?u) = i" by (rule snd_of_exps)
have "nat_term_compare (DEG to1) ?u ?v = nat_term_compare (POT to2) ?u ?v"
by (rule nat_term_order_eqD, fact a, simp_all add: ‹¬ ps›)
thus False
by (simp add: nat_term_compare_DEG deg_comp pot_comp nat_term_compare_POT
comparator_of_def comp_of_ord_def lex_pp_of_exps eq_of_exps eq ‹i ≠ 0› del: One_nat_def)
qed
moreover from this a have "nat_term_order_eq (DEG to1) to2 False ps" by (simp add: nat_term_order_eq_POT_ps')
ultimately show "(ps ∨ is_scalar TYPE('a)) ∧ nat_term_order_eq (DEG to1) to2 False ps" ..
qed (simp add: nat_term_order_eq_POT_ps')
qed
qed (fact nat_term_order_eq_sym)+
lemma POT_eq [code]:
"nat_term_order_eq (POT to) LEX dg ps = nat_term_order_eq LEX (POT to) dg ps"
"nat_term_order_eq (POT to1) (DEG to2) dg ps = nat_term_order_eq (DEG to2) (POT to1) dg ps"
"nat_term_order_eq (POT to1) DRLEX dg ps = nat_term_order_eq DRLEX (POT to1) dg ps"
"nat_term_order_eq (POT to1) (POT (to2::'a::nat_term_compare nat_term_order)) dg ps =
nat_term_order_eq to1 to2 dg True" (is ?thesis4)
proof -
show ?thesis4
proof (rule iffI)
assume a: "nat_term_order_eq (POT to1) (POT to2) dg ps"
show "nat_term_order_eq to1 to2 dg True"
proof (rule nat_term_order_eqI)
fix u v :: 'a
assume "dg ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
and b: "True ⟹ snd (rep_nat_term u) = snd (rep_nat_term v)"
with a have "nat_term_compare (POT to1) u v = nat_term_compare (POT to2) u v"
by (rule nat_term_order_eqD, blast+)
thus "nat_term_compare to1 u v = nat_term_compare to2 u v"
by (simp add: nat_term_compare_POT pot_comp comparator_of_def b)
qed
next
assume a: "nat_term_order_eq to1 to2 dg True"
show "nat_term_order_eq (POT to1) (POT to2) dg ps"
proof (rule nat_term_order_eqI)
fix u v :: 'a
assume b: "dg ⟹ deg_pp (fst (rep_nat_term u)) = deg_pp (fst (rep_nat_term v))"
show "nat_term_compare (POT to1) u v = nat_term_compare (POT to2) u v"
proof (simp add: nat_term_compare_POT pot_comp comparator_of_def split: order.split, rule impI)
assume "snd (rep_nat_term u) = snd (rep_nat_term v)"
with a b show "nat_term_compare to1 u v = nat_term_compare to2 u v" by (rule nat_term_order_eqD)
qed
qed
qed
qed (fact nat_term_order_eq_sym)+
lemma nat_term_order_equal [code]: "HOL.equal to1 to2 = nat_term_order_eq to1 to2 False False"
by (auto simp: nat_term_order_eq_def equal_eq nat_term_compare_inject[symmetric])
hide_const (open) of_exps
value [code] "DEG (POT DRLEX) = (DRLEX::((nat, nat) pp × nat) nat_term_order)"
value [code] "POT LEX = (LEX::((nat, nat) pp × nat) nat_term_order)"
value [code] "POT LEX = (LEX::(nat, nat) pp nat_term_order)"
end
Theory MPoly_Type_Class_OAlist
section ‹Executable Representation of Polynomial Mappings as Association Lists›
theory MPoly_Type_Class_OAlist
imports Term_Order
begin
instantiation pp :: (type, "{equal, zero}") equal
begin
definition equal_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ bool" where
"equal_pp p q ≡ (∀t. lookup_pp p t = lookup_pp q t)"
instance by standard (auto simp: equal_pp_def intro: pp_eqI)
end
instantiation poly_mapping :: (type, "{equal, zero}") equal
begin
definition equal_poly_mapping :: "('a, 'b) poly_mapping ⇒ ('a, 'b) poly_mapping ⇒ bool" where
equal_poly_mapping_def [code del]: "equal_poly_mapping p q ≡ (∀t. lookup p t = lookup q t)"
instance by standard (auto simp: equal_poly_mapping_def intro: poly_mapping_eqI)
end
subsection ‹Power-Products Represented by @{type oalist_tc}›
definition PP_oalist :: "('a::linorder, 'b::zero) oalist_tc ⇒ ('a, 'b) pp"
where "PP_oalist xs = pp_of_fun (OAlist_tc_lookup xs)"
code_datatype PP_oalist
lemma lookup_PP_oalist [simp, code]: "lookup_pp (PP_oalist xs) = OAlist_tc_lookup xs"
unfolding PP_oalist_def
proof (rule lookup_pp_of_fun)
have "{x. OAlist_tc_lookup xs x ≠ 0} ⊆ fst ` set (list_of_oalist_tc xs)"
proof (rule, simp)
fix x
assume "OAlist_tc_lookup xs x ≠ 0"
thus "x ∈ fst ` set (list_of_oalist_tc xs)"
using in_OAlist_tc_sorted_domain_iff_lookup set_OAlist_tc_sorted_domain by blast
qed
also have "finite ..." by simp
finally (finite_subset) show "finite {x. OAlist_tc_lookup xs x ≠ 0}" .
qed
lemma keys_PP_oalist [code]: "keys_pp (PP_oalist xs) = set (OAlist_tc_sorted_domain xs)"
by (rule set_eqI, simp add: keys_pp_iff in_OAlist_tc_sorted_domain_iff_lookup)
lemma lex_comp_PP_oalist [code]:
"lex_comp' (PP_oalist xs) (PP_oalist ys) =
the (OAlist_tc_lex_ord (λ_ x y. Some (comparator_of x y)) xs ys)"
for xs ys::"('a::nat, 'b::nat) oalist_tc"
proof (cases "lex_comp' (PP_oalist xs) (PP_oalist ys) = Eq")
case True
hence "PP_oalist xs = PP_oalist ys" by (rule lex_comp'_EqD)
hence eq: "OAlist_tc_lookup xs = OAlist_tc_lookup ys" by (simp add: pp_eq_iff)
have "OAlist_tc_lex_ord (λ_ x y. Some (comparator_of x y)) xs ys = Some Eq"
by (rule OAlist_tc_lex_ord_EqI, simp add: eq)
thus ?thesis by (simp add: True)
next
case False
then obtain x where 1: "x ∈ keys_pp (rep_nat_pp (PP_oalist xs)) ∪ keys_pp (rep_nat_pp (PP_oalist ys))"
and 2: "comparator_of (lookup_pp (rep_nat_pp (PP_oalist xs)) x) (lookup_pp (rep_nat_pp (PP_oalist ys)) x) =
lex_comp' (PP_oalist xs) (PP_oalist ys)"
and 3: "⋀y. y < x ⟹ lookup_pp (rep_nat_pp (PP_oalist xs)) y = lookup_pp (rep_nat_pp (PP_oalist ys)) y"
by (rule lex_comp'_valE, blast)
have "OAlist_tc_lex_ord (λ_ x y. Some (comparator_of x y)) xs ys = Some (lex_comp' (PP_oalist xs) (PP_oalist ys))"
proof (rule OAlist_tc_lex_ord_valI)
from False show "Some (lex_comp' (PP_oalist xs) (PP_oalist ys)) ≠ Some Eq" by simp
next
from 1 have "abs_nat x ∈ abs_nat ` (keys_pp (rep_nat_pp (PP_oalist xs)) ∪ keys_pp (rep_nat_pp (PP_oalist ys)))"
by (rule imageI)
also have "... = fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys)"
by (simp add: keys_rep_nat_pp_pp keys_PP_oalist OAlist_tc_sorted_domain_def image_Un image_image)
finally show "abs_nat x ∈ fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys)" .
next
show "Some (lex_comp' (PP_oalist xs) (PP_oalist ys)) =
Some (comparator_of (OAlist_tc_lookup xs (abs_nat x)) (OAlist_tc_lookup ys (abs_nat x)))"
by (simp add: 2[symmetric] lookup_rep_nat_pp_pp)
next
fix y::'a
assume "y < abs_nat x"
hence "rep_nat y < x" by (metis abs_inverse ord_iff(2))
hence "lookup_pp (rep_nat_pp (PP_oalist xs)) (rep_nat y) = lookup_pp (rep_nat_pp (PP_oalist ys)) (rep_nat y)"
by (rule 3)
hence "OAlist_tc_lookup xs y = OAlist_tc_lookup ys y" by (auto simp: lookup_rep_nat_pp_pp elim: rep_inj)
thus "Some (comparator_of (OAlist_tc_lookup xs y) (OAlist_tc_lookup ys y)) = Some Eq" by simp
qed
thus ?thesis by simp
qed
lemma zero_PP_oalist [code]: "(0::('a::linorder, 'b::zero) pp) = PP_oalist OAlist_tc_empty"
by (rule pp_eqI, simp add: lookup_OAlist_tc_empty)
lemma plus_PP_oalist [code]:
"PP_oalist xs + PP_oalist ys = PP_oalist (OAlist_tc_map2_val_neutr (λ_. (+)) xs ys)"
by (rule pp_eqI, simp add: lookup_plus_pp, rule lookup_OAlist_tc_map2_val_neutr[symmetric], simp_all)
lemma minus_PP_oalist [code]:
"PP_oalist xs - PP_oalist ys = PP_oalist (OAlist_tc_map2_val_rneutr (λ_. (-)) xs ys)"
by (rule pp_eqI, simp add: lookup_minus_pp, rule lookup_OAlist_tc_map2_val_rneutr[symmetric], simp)
lemma equal_PP_oalist [code]: "equal_class.equal (PP_oalist xs) (PP_oalist ys) = (xs = ys)"
by (simp add: equal_eq pp_eq_iff, auto elim: OAlist_tc_lookup_inj)
lemma lcs_PP_oalist [code]:
"lcs (PP_oalist xs) (PP_oalist ys) = PP_oalist (OAlist_tc_map2_val_neutr (λ_. max) xs ys)"
for xs ys :: "('a::linorder, 'b::add_linorder_min) oalist_tc"
by (rule pp_eqI, simp add: lookup_lcs_pp, rule lookup_OAlist_tc_map2_val_neutr[symmetric], simp_all add: max_def)
lemma deg_pp_PP_oalist [code]: "deg_pp (PP_oalist xs) = sum_list (map snd (list_of_oalist_tc xs))"
proof -
have "irreflp ((<)::_::linorder ⇒ _)" by (rule irreflpI, simp)
have "deg_pp (PP_oalist xs) = sum (OAlist_tc_lookup xs) (set (OAlist_tc_sorted_domain xs))"
by (simp add: deg_pp_alt keys_PP_oalist)
also have "... = sum_list (map (OAlist_tc_lookup xs) (OAlist_tc_sorted_domain xs))"
by (rule sum.distinct_set_conv_list, rule distinct_sorted_wrt_irrefl,
fact, fact transp_less, fact sorted_OAlist_tc_sorted_domain)
also have "... = sum_list (map snd (list_of_oalist_tc xs))"
by (rule arg_cong[where f=sum_list], simp add: OAlist_tc_sorted_domain_def OAlist_tc_lookup_eq_valueI)
finally show ?thesis .
qed
lemma single_PP_oalist [code]: "single_pp x e = PP_oalist (oalist_tc_of_list [(x, e)])"
by (rule pp_eqI, simp add: lookup_single_pp OAlist_tc_lookup_single)
definition adds_pp_add_linorder :: "('b, 'a::add_linorder) pp ⇒ _ ⇒ bool"
where [code_abbrev]: "adds_pp_add_linorder = (adds)"
lemma adds_pp_PP_oalist [code]:
"adds_pp_add_linorder (PP_oalist xs) (PP_oalist ys) = OAlist_tc_prod_ord (λ_. less_eq) xs ys"
for xs ys::"('a::linorder, 'b::add_linorder_min) oalist_tc"
proof (simp add: adds_pp_add_linorder_def adds_pp_iff adds_poly_mapping lookup_pp.rep_eq[symmetric] OAlist_tc_prod_ord_alt le_fun_def,
intro iffI allI ballI)
fix k
assume "∀x. OAlist_tc_lookup xs x ≤ OAlist_tc_lookup ys x"
thus "OAlist_tc_lookup xs k ≤ OAlist_tc_lookup ys k" by blast
next
fix x
assume *: "∀k∈fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys).
OAlist_tc_lookup xs k ≤ OAlist_tc_lookup ys k"
show "OAlist_tc_lookup xs x ≤ OAlist_tc_lookup ys x"
proof (cases "x ∈ fst ` set (list_of_oalist_tc xs) ∪ fst ` set (list_of_oalist_tc ys)")
case True
with * show ?thesis ..
next
case False
hence "x ∉ set (OAlist_tc_sorted_domain xs)" and "x ∉ set (OAlist_tc_sorted_domain ys)"
by (simp_all add: set_OAlist_tc_sorted_domain)
thus ?thesis by (simp add: in_OAlist_tc_sorted_domain_iff_lookup)
qed
qed
subsubsection ‹Constructor›
definition "sparse⇩0 xs = PP_oalist (oalist_tc_of_list xs)"
subsubsection ‹Computations›
experiment begin
abbreviation "X ≡ 0::nat"
abbreviation "Y ≡ 1::nat"
abbreviation "Z ≡ 2::nat"
value [code] "sparse⇩0 [(X, 2::nat), (Z, 7)]"
lemma
"sparse⇩0 [(X, 2::nat), (Z, 7)] - sparse⇩0 [(X, 2), (Z, 2)] = sparse⇩0 [(Z, 5)]"
by eval
lemma
"lcs (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 7)]) (sparse⇩0 [(Y, 3), (Z, 2)]) = sparse⇩0 [(X, 2), (Y, 3), (Z, 7)]"
by eval
lemma
"(sparse⇩0 [(X, 2::nat), (Z, 1)]) adds (sparse⇩0 [(X, 3), (Y, 2), (Z, 1)])"
by eval
lemma
"lookup_pp (sparse⇩0 [(X, 2::nat), (Z, 3)]) X = 2"
by eval
lemma
"deg_pp (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 3), (X, 1)]) = 6"
by eval
lemma
"lex_comp (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse⇩0 [(X, 4)]) = Lt"
by eval
lemma
"lex_comp (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 3)], 3::nat) (sparse⇩0 [(X, 4)], 2) = Lt"
by eval
lemma
"lex_pp (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse⇩0 [(X, 4)])"
by eval
lemma
"lex_pp (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse⇩0 [(X, 4)])"
by eval
lemma
"¬ dlex_pp (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse⇩0 [(X, 4)])"
by eval
lemma
"dlex_pp (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse⇩0 [(X, 5)])"
by eval
lemma
"¬ drlex_pp (sparse⇩0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse⇩0 [(X, 5)])"
by eval
end
subsection ‹‹MP_oalist››
lift_definition MP_oalist :: "('a::nat_term, 'b::zero) oalist_ntm ⇒ 'a ⇒⇩0 'b"
is OAlist_lookup_ntm
proof -
fix xs :: "('a, 'b) oalist_ntm"
have "{x. OAlist_lookup_ntm xs x ≠ 0} ⊆ fst ` set (fst (list_of_oalist_ntm xs))"
proof (rule, simp)
fix x
assume "OAlist_lookup_ntm xs x ≠ 0"
thus "x ∈ fst ` set (fst (list_of_oalist_ntm xs))"
using oa_ntm.in_sorted_domain_iff_lookup oa_ntm.set_sorted_domain by blast
qed
also have "finite ..." by simp
finally (finite_subset) show "finite {x. OAlist_lookup_ntm xs x ≠ 0}" .
qed
lemmas [simp, code] = MP_oalist.rep_eq
code_datatype MP_oalist
lemma keys_MP_oalist [code]: "keys (MP_oalist xs) = set (map fst (fst (list_of_oalist_ntm xs)))"
by (rule set_eqI, simp add: in_keys_iff oa_ntm.in_sorted_domain_iff_lookup[simplified oa_ntm.set_sorted_domain])
lemma MP_oalist_empty [simp]: "MP_oalist (OAlist_empty_ntm ko) = 0"
by (rule poly_mapping_eqI, simp add: oa_ntm.lookup_empty)
lemma zero_MP_oalist [code]: "(0::('a::{linorder,nat_term} ⇒⇩0 'b::zero)) = MP_oalist (OAlist_empty_ntm nat_term_order_of_le)"
by simp
definition is_zero :: "('a ⇒⇩0 'b::zero) ⇒ bool"
where [code_abbrev]: "is_zero p ⟷ (p = 0)"
lemma is_zero_MP_oalist [code]: "is_zero (MP_oalist xs) = List.null (fst (list_of_oalist_ntm xs))"
unfolding is_zero_def List.null_def
proof
assume "MP_oalist xs = 0"
hence "OAlist_lookup_ntm xs k = 0" for k by (simp add: poly_mapping_eq_iff)
thus "fst (list_of_oalist_ntm xs) = []"
by (metis image_eqI ko_ntm.min_key_val_raw_in oa_ntm.in_sorted_domain_iff_lookup oa_ntm.set_sorted_domain)
next
assume "fst (list_of_oalist_ntm xs) = []"
hence "OAlist_lookup_ntm xs k = 0" for k
by (metis oa_ntm.list_of_oalist_empty oa_ntm.lookup_empty oalist_ntm_eqI surjective_pairing)
thus "MP_oalist xs = 0" by (simp add: poly_mapping_eq_iff ext)
qed
lemma plus_MP_oalist [code]: "MP_oalist xs + MP_oalist ys = MP_oalist (OAlist_map2_val_neutr_ntm (λ_. (+)) xs ys)"
by (rule poly_mapping_eqI, simp add: lookup_plus_fun, rule oa_ntm.lookup_map2_val_neutr[symmetric], simp_all)
lemma minus_MP_oalist [code]: "MP_oalist xs - MP_oalist ys = MP_oalist (OAlist_map2_val_rneutr_ntm (λ_. (-)) xs ys)"
by (rule poly_mapping_eqI, simp add: lookup_minus_fun, rule oa_ntm.lookup_map2_val_rneutr[symmetric], simp)
lemma uminus_MP_oalist [code]: "- MP_oalist xs = MP_oalist (OAlist_map_val_ntm (λ_. uminus) xs)"
by (rule poly_mapping_eqI, simp, rule oa_ntm.lookup_map_val[symmetric], simp)
lemma equal_MP_oalist [code]: "equal_class.equal (MP_oalist xs) (MP_oalist ys) = (OAlist_eq_ntm xs ys)"
by (simp add: oa_ntm.oalist_eq_alt equal_eq poly_mapping_eq_iff)
lemma map_MP_oalist [code]: "Poly_Mapping.map f (MP_oalist xs) = MP_oalist (OAlist_map_val_ntm (λ_. f) xs)"
proof -
have eq: "OAlist_map_val_ntm (λ_. f) xs = OAlist_map_val_ntm (λ_ c. f c when c ≠ 0) xs"
proof (rule oa_ntm.map_val_cong)
fix t c
assume *: "(t, c) ∈ set (fst (list_of_oalist_ntm xs))"
hence "fst (t, c) ∈ fst ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
hence "OAlist_lookup_ntm xs t ≠ 0"
by (simp add: oa_ntm.in_sorted_domain_iff_lookup[simplified oa_ntm.set_sorted_domain])
moreover from * have "OAlist_lookup_ntm xs t = c" by (rule oa_ntm.lookup_eq_valueI)
ultimately have "c ≠ 0" by simp
thus "f c = (f c when c ≠ 0)" by simp
qed
show ?thesis
by (rule poly_mapping_eqI, simp add: Poly_Mapping.map.rep_eq eq, rule oa_ntm.lookup_map_val[symmetric], simp)
qed
lemma range_MP_oalist [code]: "Poly_Mapping.range (MP_oalist xs) = set (map snd (fst (list_of_oalist_ntm xs)))"
proof (simp add: Poly_Mapping.range.rep_eq, intro set_eqI iffI)
fix c
assume "c ∈ range (OAlist_lookup_ntm xs) - {0}"
hence "c ∈ range (OAlist_lookup_ntm xs)" and "c ≠ 0" by simp_all
from this(1) obtain t where "OAlist_lookup_ntm xs t = c" by fastforce
with ‹c ≠ 0› have "(t, c) ∈ set (fst (list_of_oalist_ntm xs))" by (simp add: oa_ntm.lookup_eq_value)
hence "snd (t, c) ∈ snd ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
thus "c ∈ snd ` set (fst (list_of_oalist_ntm xs))" by simp
next
fix c
assume "c ∈ snd ` set (fst (list_of_oalist_ntm xs))"
then obtain t where *: "(t, c) ∈ set (fst (list_of_oalist_ntm xs))" by fastforce
hence "fst (t, c) ∈ fst ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
hence "OAlist_lookup_ntm xs t ≠ 0"
by (simp add: oa_ntm.in_sorted_domain_iff_lookup[simplified oa_ntm.set_sorted_domain])
moreover from * have "OAlist_lookup_ntm xs t = c" by (rule oa_ntm.lookup_eq_valueI)
ultimately show "c ∈ range (OAlist_lookup_ntm xs) - {0}" by fastforce
qed
lemma if_poly_mapping_eq_iff:
"(if x = y then a else b) = (if (∀i∈keys x ∪ keys y. lookup x i = lookup y i) then a else b)"
by simp (metis UnI1 UnI2 in_keys_iff poly_mapping_eqI)
lemma keys_add_eq: "keys (a + b) = keys a ∪ keys b - {x ∈ keys a ∩ keys b. lookup a x + lookup b x = 0}"
by (auto simp: in_keys_iff lookup_add add_eq_0_iff
simp del: lookup_not_eq_zero_eq_in_keys)
locale gd_nat_term =
gd_term pair_of_term term_of_pair
"λs t. le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
"λs t. lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
"le_of_nat_term_order cmp_term"
"lt_of_nat_term_order cmp_term"
for pair_of_term::"'t::nat_term ⇒ ('a::{nat_term,graded_dickson_powerprod} × 'k::{countable,the_min,wellorder})"
and term_of_pair::"('a × 'k) ⇒ 't"
and cmp_term +
assumes splus_eq_splus: "t ⊕ u = nat_term_class.splus (term_of_pair (t, the_min)) u"
begin
definition shift_map_keys :: "'a ⇒ ('b ⇒ 'b) ⇒ ('t, 'b) oalist_ntm ⇒ ('t, 'b::semiring_0) oalist_ntm"
where "shift_map_keys t f xs = OAlist_ntm (map_raw (λkv. (t ⊕ fst kv, f (snd kv))) (list_of_oalist_ntm xs))"
lemma list_of_oalist_shift_keys:
"list_of_oalist_ntm (shift_map_keys t f xs) = (map_raw (λkv. (t ⊕ fst kv, f (snd kv))) (list_of_oalist_ntm xs))"
unfolding shift_map_keys_def
by (rule oa_ntm.list_of_oalist_of_list_id, rule ko_ntm.oalist_inv_map_raw, fact oalist_inv_list_of_oalist_ntm,
simp add: nat_term_compare_inv_conv[symmetric] nat_term_compare_inv_def splus_eq_splus nat_term_compare_splus)
lemma lookup_shift_map_keys_plus:
"lookup (MP_oalist (shift_map_keys t ((*) c) xs)) (t ⊕ u) = c * lookup (MP_oalist xs) u" (is "?l = ?r")
proof -
let ?f = "λkv. (t ⊕ fst kv, c * snd kv)"
have "?l = lookup_ko_ntm (map_raw ?f (list_of_oalist_ntm xs)) (fst (?f (u, c)))"
by (simp add: oa_ntm.lookup_def list_of_oalist_shift_keys)
also have "... = snd (?f (u, lookup_ko_ntm (list_of_oalist_ntm xs) u))"
by (rule ko_ntm.lookup_raw_map_raw, fact oalist_inv_list_of_oalist_ntm, simp,
simp add: nat_term_compare_inv_conv[symmetric] nat_term_compare_inv_def splus_eq_splus nat_term_compare_splus)
also have "... = ?r" by (simp add: oa_ntm.lookup_def)
finally show ?thesis .
qed
lemma keys_shift_map_keys_subset:
"keys (MP_oalist (shift_map_keys t ((*) c) xs)) ⊆ ((⊕) t) ` keys (MP_oalist xs)" (is "?l ⊆ ?r")
proof -
let ?f = "λkv. (t ⊕ fst kv, c * snd kv)"
have "?l = fst ` set (fst (map_raw ?f (list_of_oalist_ntm xs)))"
by (simp add: keys_MP_oalist list_of_oalist_shift_keys)
also from ko_ntm.map_raw_subset have "... ⊆ fst ` ?f ` set (fst (list_of_oalist_ntm xs))"
by (rule image_mono)
also have "... ⊆ ?r" by (simp add: keys_MP_oalist image_image)
finally show ?thesis .
qed
lemma monom_mult_MP_oalist [code]:
"monom_mult c t (MP_oalist xs) =
MP_oalist (if c = 0 then OAlist_empty_ntm (snd (list_of_oalist_ntm xs)) else shift_map_keys t ((*) c) xs)"
proof (cases "c = 0")
case True
hence "monom_mult c t (MP_oalist xs) = 0" using monom_mult_zero_left by simp
thus ?thesis using True by simp
next
case False
have "monom_mult c t (MP_oalist xs) = MP_oalist (shift_map_keys t ((*) c) xs)"
proof (rule poly_mapping_eqI, simp add: lookup_monom_mult del: MP_oalist.rep_eq, intro conjI impI)
fix u
assume "t adds⇩p u"
then obtain v where "u = t ⊕ v" by (rule adds_ppE)
thus "c * lookup (MP_oalist xs) (u ⊖ t) = lookup (MP_oalist (shift_map_keys t ((*) c) xs)) u"
by (simp add: splus_sminus lookup_shift_map_keys_plus del: MP_oalist.rep_eq)
next
fix u
assume "¬ t adds⇩p u"
have "u ∉ keys (MP_oalist (shift_map_keys t ((*) c) xs))"
proof
assume "u ∈ keys (MP_oalist (shift_map_keys t ((*) c) xs))"
also have "... ⊆ ((⊕) t) ` keys (MP_oalist xs)" by (fact keys_shift_map_keys_subset)
finally obtain v where "u = t ⊕ v" ..
hence "t adds⇩p u" by (rule adds_ppI)
with ‹¬ t adds⇩p u› show False ..
qed
thus "lookup (MP_oalist (shift_map_keys t ((*) c) xs)) u = 0" by (simp add: in_keys_iff)
qed
thus ?thesis by (simp add: False)
qed
lemma mult_scalar_MP_oalist [code]:
"(MP_oalist xs) ⊙ (MP_oalist ys) =
(if is_zero (MP_oalist xs) then
MP_oalist (OAlist_empty_ntm (snd (list_of_oalist_ntm ys)))
else
let ct = OAlist_hd_ntm xs in
monom_mult (snd ct) (fst ct) (MP_oalist ys) + (MP_oalist (OAlist_tl_ntm xs)) ⊙ (MP_oalist ys))"
proof (split if_split, intro conjI impI)
assume "is_zero (MP_oalist xs)"
thus "MP_oalist xs ⊙ MP_oalist ys = MP_oalist (OAlist_empty_ntm (snd (list_of_oalist_ntm ys)))"
by (simp add: is_zero_def)
next
assume "¬ is_zero (MP_oalist xs)"
hence *: "fst (list_of_oalist_ntm xs) ≠ []" by (simp add: is_zero_MP_oalist List.null_def)
define ct where "ct = OAlist_hd_ntm xs"
have eq: "except (MP_oalist xs) {fst ct} = MP_oalist (OAlist_tl_ntm xs)"
by (rule poly_mapping_eqI, simp add: lookup_except ct_def oa_ntm.lookup_tl')
have "MP_oalist xs ⊙ MP_oalist ys =
monom_mult (lookup (MP_oalist xs) (fst ct)) (fst ct) (MP_oalist ys) +
except (MP_oalist xs) {fst ct} ⊙ MP_oalist ys" by (fact mult_scalar_rec_left)
also have "... = monom_mult (snd ct) (fst ct) (MP_oalist ys) + except (MP_oalist xs) {fst ct} ⊙ MP_oalist ys"
using * by (simp add: ct_def oa_ntm.snd_hd)
also have "... = monom_mult (snd ct) (fst ct) (MP_oalist ys) + MP_oalist (OAlist_tl_ntm xs) ⊙ MP_oalist ys"
by (simp only: eq)
finally show "MP_oalist xs ⊙ MP_oalist ys =
(let ct = OAlist_hd_ntm xs in
monom_mult (snd ct) (fst ct) (MP_oalist ys) + MP_oalist (OAlist_tl_ntm xs) ⊙ MP_oalist ys)"
by (simp add: ct_def Let_def)
qed
end
subsubsection ‹Special case of addition: adding monomials›
definition plus_monomial_less :: "('a ⇒⇩0 'b) ⇒ 'b ⇒ 'a ⇒ ('a ⇒⇩0 'b::monoid_add)"
where "plus_monomial_less p c u = p + monomial c u"
text ‹@{const plus_monomial_less} is useful when adding a monomial to a polynomial, where the term
of the monomial is known to be smaller than all terms in the polynomial, because it can be
implemented more efficiently than general addition.›
lemma plus_monomial_less_MP_oalist [code]:
"plus_monomial_less (MP_oalist xs) c u = MP_oalist (OAlist_update_by_fun_gr_ntm u (λc0. c0 + c) xs)"
unfolding plus_monomial_less_def oa_ntm.update_by_fun_gr_eq_update_by_fun
by (rule poly_mapping_eqI, simp add: lookup_plus_fun oa_ntm.lookup_update_by_fun lookup_single)
text ‹@{const plus_monomial_less} is computed by @{const OAlist_update_by_fun_gr_ntm}, because greater
terms come @{emph ‹before›} smaller ones in @{type oalist_ntm}.›
subsubsection ‹Constructors›
definition "distr⇩0 ko xs = MP_oalist (oalist_of_list_ntm (xs, ko))"
definition V⇩0 :: "'a ⇒ ('a, nat) pp ⇒⇩0 'b::{one,zero}" where
"V⇩0 n ≡ monomial 1 (single_pp n 1)"
definition C⇩0 :: "'b ⇒ ('a, nat) pp ⇒⇩0 'b::zero" where "C⇩0 c ≡ monomial c 0"
lemma C⇩0_one: "C⇩0 1 = 1"
by (simp add: C⇩0_def)
lemma C⇩0_numeral: "C⇩0 (numeral x) = numeral x"
by (auto intro!: poly_mapping_eqI simp: C⇩0_def lookup_numeral)
lemma C⇩0_minus: "C⇩0 (- x) = - C⇩0 x"
by (simp add: C⇩0_def single_uminus)
lemma C⇩0_zero: "C⇩0 0 = 0"
by (auto intro!: poly_mapping_eqI simp: C⇩0_def)
lemma V⇩0_power: "V⇩0 v ^ n = monomial 1 (single_pp v n)"
by (induction n) (auto simp: V⇩0_def mult_single single_pp_plus)
lemma single_MP_oalist [code]: "Poly_Mapping.single k v = distr⇩0 nat_term_order_of_le [(k, v)]"
unfolding distr⇩0_def by (rule poly_mapping_eqI, simp add: lookup_single OAlist_lookup_ntm_single)
lemma one_MP_oalist [code]: "1 = distr⇩0 nat_term_order_of_le [(0, 1)]"
by (metis single_MP_oalist single_one)
lemma except_MP_oalist [code]: "except (MP_oalist xs) S = MP_oalist (OAlist_filter_ntm (λkv. fst kv ∉ S) xs)"
by (rule poly_mapping_eqI, simp add: lookup_except oa_ntm.lookup_filter)
subsubsection ‹Changing the Internal Order›
definition change_ord :: "'a::nat_term_compare nat_term_order ⇒ ('a ⇒⇩0 'b) ⇒ ('a ⇒⇩0 'b)"
where "change_ord to = (λx. x)"
lemma change_ord_MP_oalist [code]: "change_ord to (MP_oalist xs) = MP_oalist (OAlist_reorder_ntm to xs)"
by (rule poly_mapping_eqI, simp add: change_ord_def oa_ntm.lookup_reorder)
subsubsection ‹Ordered Power-Products›
lemma foldl_assoc:
assumes "⋀x y z. f (f x y) z = f x (f y z)"
shows "foldl f (f a b) xs = f a (foldl f b xs)"
proof (induct xs arbitrary: a b)
fix a b
show "foldl f (f a b) [] = f a (foldl f b [])" by simp
next
fix a b x xs
assume "⋀a b. foldl f (f a b) xs = f a (foldl f b xs)"
from assms[of a b x] this[of a "f b x"]
show "foldl f (f a b) (x # xs) = f a (foldl f b (x # xs))" unfolding foldl_Cons by simp
qed
context gd_nat_term
begin
definition ord_pp :: "'a ⇒ 'a ⇒ bool"
where "ord_pp s t = le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
definition ord_pp_strict :: "'a ⇒ 'a ⇒ bool"
where "ord_pp_strict s t = lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
lemma lt_MP_oalist [code]:
"lt (MP_oalist xs) = (if is_zero (MP_oalist xs) then min_term else fst (OAlist_min_key_val_ntm cmp_term xs))"
proof (split if_split, intro conjI impI)
assume "is_zero (MP_oalist xs)"
thus "lt (MP_oalist xs) = min_term" by (simp add: is_zero_def)
next
assume "¬ is_zero (MP_oalist xs)"
hence "fst (list_of_oalist_ntm xs) ≠ []" by (simp add: is_zero_MP_oalist List.null_def)
show "lt (MP_oalist xs) = fst (OAlist_min_key_val_ntm cmp_term xs)"
proof (rule lt_eqI_keys)
show "fst (OAlist_min_key_val_ntm cmp_term xs) ∈ keys (MP_oalist xs)"
by (simp add: keys_MP_oalist, rule imageI, rule oa_ntm.min_key_val_in, fact)
next
fix u
assume "u ∈ keys (MP_oalist xs)"
also have "... = fst ` set (fst (list_of_oalist_ntm xs))" by (simp add: keys_MP_oalist)
finally obtain z where "z ∈ set (fst (list_of_oalist_ntm xs))" and "u = fst z" ..
from this(1) have "ko.le (key_order_of_nat_term_order_inv cmp_term) (fst (OAlist_min_key_val_ntm cmp_term xs)) u"
unfolding ‹u = fst z› by (rule oa_ntm.min_key_val_minimal)
thus "le_of_nat_term_order cmp_term u (fst (OAlist_min_key_val_ntm cmp_term xs))"
by (simp add: le_of_nat_term_order_alt)
qed
qed
lemma lc_MP_oalist [code]:
"lc (MP_oalist xs) = (if is_zero (MP_oalist xs) then 0 else snd (OAlist_min_key_val_ntm cmp_term xs))"
proof (split if_split, intro conjI impI)
assume "is_zero (MP_oalist xs)"
thus "lc (MP_oalist xs) = 0" by (simp add: is_zero_def)
next
assume "¬ is_zero (MP_oalist xs)"
moreover from this have "fst (list_of_oalist_ntm xs) ≠ []" by (simp add: is_zero_MP_oalist List.null_def)
ultimately show "lc (MP_oalist xs) = snd (OAlist_min_key_val_ntm cmp_term xs)"
by (simp add: lc_def lt_MP_oalist oa_ntm.snd_min_key_val)
qed
lemma tail_MP_oalist [code]: "tail (MP_oalist xs) = MP_oalist (OAlist_except_min_ntm cmp_term xs)"
proof (cases "is_zero (MP_oalist xs)")
case True
hence "fst (list_of_oalist_ntm xs) = []" by (simp add: is_zero_MP_oalist List.null_def)
hence "fst (list_of_oalist_ntm (OAlist_except_min_ntm cmp_term xs)) = []"
by (rule oa_ntm.except_min_Nil)
hence "is_zero (MP_oalist (OAlist_except_min_ntm cmp_term xs))"
by (simp add: is_zero_MP_oalist List.null_def)
with True show ?thesis by (simp add: is_zero_def)
next
case False
show ?thesis by (rule poly_mapping_eqI, simp add: lookup_tail_2 oa_ntm.lookup_except_min' lt_MP_oalist False)
qed
definition comp_opt_p :: "('t ⇒⇩0 'c::zero, 't ⇒⇩0 'c) comp_opt"
where "comp_opt_p p q =
(if p = q then Some Eq else if ord_strict_p p q then Some Lt else if ord_strict_p q p then Some Gt else None)"
lemma comp_opt_p_MP_oalist [code]:
"comp_opt_p (MP_oalist xs) (MP_oalist ys) =
OAlist_lex_ord_ntm cmp_term (λ_ x y. if x = y then Some Eq else if x = 0 then Some Lt else if y = 0 then Some Gt else None) xs ys"
proof -
let ?f = "λ_ x y. if x = y then Some Eq else if x = 0 then Some Lt else if y = 0 then Some Gt else None"
show ?thesis
proof (cases "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Eq")
case True
hence "MP_oalist xs = MP_oalist ys" by (simp add: comp_opt_p_def split: if_splits)
hence "lookup (MP_oalist xs) = lookup (MP_oalist ys)" by (rule arg_cong)
hence eq: "OAlist_lookup_ntm xs = OAlist_lookup_ntm ys" by simp
have "OAlist_lex_ord_ntm cmp_term ?f xs ys = Some Eq"
by (rule oa_ntm.lex_ord_EqI, simp add: eq)
with True show ?thesis by simp
next
case False
hence neq: "MP_oalist xs ≠ MP_oalist ys" by (simp add: comp_opt_p_def split: if_splits)
then obtain v where 1: "v ∈ keys (MP_oalist xs) ∪ keys (MP_oalist ys)"
and 2: "lookup (MP_oalist xs) v ≠ lookup (MP_oalist ys) v"
and 3: "⋀u. lt_of_nat_term_order cmp_term v u ⟹ lookup (MP_oalist xs) u = lookup (MP_oalist ys) u"
by (rule poly_mapping_neqE, blast)
show ?thesis
proof (rule HOL.sym, rule oa_ntm.lex_ord_valI)
from 1 show "v ∈ fst ` set (fst (list_of_oalist_ntm xs)) ∪ fst ` set (fst (list_of_oalist_ntm ys))"
by (simp add: keys_MP_oalist)
next
from 2 have 4: "OAlist_lookup_ntm xs v ≠ OAlist_lookup_ntm ys v" by simp
show "comp_opt_p (MP_oalist xs) (MP_oalist ys) =
(if OAlist_lookup_ntm xs v = OAlist_lookup_ntm ys v then Some Eq
else if OAlist_lookup_ntm xs v = 0 then Some Lt
else if OAlist_lookup_ntm ys v = 0 then Some Gt else None)"
proof (simp add: 4, intro conjI impI)
assume "OAlist_lookup_ntm ys v = 0" and "OAlist_lookup_ntm xs v = 0"
with 4 show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Lt" by simp
next
assume "OAlist_lookup_ntm xs v ≠ 0" and "OAlist_lookup_ntm ys v = 0"
hence "lookup (MP_oalist ys) v = 0" and "lookup (MP_oalist xs) v ≠ 0" by simp_all
hence "ord_strict_p (MP_oalist ys) (MP_oalist xs)" using 3[symmetric]
by (rule ord_strict_pI)
with neq show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Gt" by (auto simp: comp_opt_p_def)
next
assume "OAlist_lookup_ntm ys v ≠ 0" and "OAlist_lookup_ntm xs v = 0"
hence "lookup (MP_oalist xs) v = 0" and "lookup (MP_oalist ys) v ≠ 0" by simp_all
hence "ord_strict_p (MP_oalist xs) (MP_oalist ys)" using 3 by (rule ord_strict_pI)
with neq show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Lt" by (auto simp: comp_opt_p_def)
next
assume "OAlist_lookup_ntm xs v ≠ 0"
hence "lookup (MP_oalist xs) v ≠ 0" by simp
with 2 have a: "¬ ord_strict_p (MP_oalist xs) (MP_oalist ys)" using 3 by (rule not_ord_strict_pI)
assume "OAlist_lookup_ntm ys v ≠ 0"
hence "lookup (MP_oalist ys) v ≠ 0" by simp
with 2[symmetric] have "¬ ord_strict_p (MP_oalist ys) (MP_oalist xs)"
using 3[symmetric] by (rule not_ord_strict_pI)
with neq a show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = None" by (auto simp: comp_opt_p_def)
qed
next
fix u
assume "ko.lt (key_order_of_nat_term_order_inv cmp_term) u v"
hence "lt_of_nat_term_order cmp_term v u" by (simp only: lt_of_nat_term_order_alt)
hence "lookup (MP_oalist xs) u = lookup (MP_oalist ys) u" by (rule 3)
thus "(if OAlist_lookup_ntm xs u = OAlist_lookup_ntm ys u then Some Eq
else if OAlist_lookup_ntm xs u = 0 then Some Lt
else if OAlist_lookup_ntm ys u = 0 then Some Gt else None) = Some Eq" by simp
qed fact
qed
qed
lemma compute_ord_p [code]: "ord_p p q = (let aux = comp_opt_p p q in aux = Some Lt ∨ aux = Some Eq)"
by (auto simp: ord_p_def comp_opt_p_def)
lemma compute_ord_p_strict [code]: "ord_strict_p p q = (comp_opt_p p q = Some Lt)"
by (auto simp: comp_opt_p_def)
lemma keys_to_list_MP_oalist [code]: "keys_to_list (MP_oalist xs) = OAlist_sorted_domain_ntm cmp_term xs"
proof -
have eq: "ko.lt (key_order_of_nat_term_order_inv cmp_term) = ord_term_strict_conv"
by (intro ext, simp add: lt_of_nat_term_order_alt)
have 1: "irreflp ord_term_strict_conv" by (rule irreflpI, simp)
have 2: "transp ord_term_strict_conv" by (rule transpI, simp)
have "antisymp ord_term_strict_conv" by (rule antisympI, simp)
moreover have 3: "sorted_wrt ord_term_strict_conv (keys_to_list (MP_oalist xs))"
unfolding keys_to_list_def by (fact pps_to_list_sorted_wrt)
moreover note _
moreover have 4: "sorted_wrt ord_term_strict_conv (OAlist_sorted_domain_ntm cmp_term xs)"
unfolding eq[symmetric] by (fact oa_ntm.sorted_sorted_domain)
ultimately show ?thesis
proof (rule sorted_wrt_distinct_set_unique)
from 1 2 3 show "distinct (keys_to_list (MP_oalist xs))" by (rule distinct_sorted_wrt_irrefl)
next
from 1 2 4 show "distinct (OAlist_sorted_domain_ntm cmp_term xs)" by (rule distinct_sorted_wrt_irrefl)
next
show "set (keys_to_list (MP_oalist xs)) = set (OAlist_sorted_domain_ntm cmp_term xs)"
by (simp add: set_keys_to_list keys_MP_oalist oa_ntm.set_sorted_domain)
qed
qed
end
lifting_update poly_mapping.lifting
lifting_forget poly_mapping.lifting
subsection ‹Interpretations›
lemma term_powerprod_gd_term:
fixes pair_of_term :: "'t::nat_term ⇒ ('a::{graded_dickson_powerprod,nat_pp_compare} × 'k::{the_min,wellorder})"
assumes "term_powerprod pair_of_term term_of_pair"
and "⋀v. fst (rep_nat_term v) = rep_nat_pp (fst (pair_of_term v))"
and "⋀t. snd (rep_nat_term (term_of_pair (t, the_min))) = 0"
and "⋀v w. snd (pair_of_term v) ≤ snd (pair_of_term w) ⟹ snd (rep_nat_term v) ≤ snd (rep_nat_term w)"
and "⋀s t k. term_of_pair (s + t, k) = splus (term_of_pair (s, k)) (term_of_pair (t, k))"
and "⋀t v. term_powerprod.splus pair_of_term term_of_pair t v = splus (term_of_pair (t, the_min)) v"
shows "gd_term pair_of_term term_of_pair
(λs t. le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min)))
(λs t. lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min)))
(le_of_nat_term_order cmp_term)
(lt_of_nat_term_order cmp_term)"
proof -
from assms(1) interpret tp: term_powerprod pair_of_term term_of_pair .
let ?f = "λx. term_of_pair (x, the_min)"
show ?thesis
proof (intro gd_term.intro ordered_term.intro)
from assms(1) show "term_powerprod pair_of_term term_of_pair" .
next
show "ordered_powerprod (λs t. le_of_nat_term_order cmp_term (?f s) (?f t))
(λs t. lt_of_nat_term_order cmp_term (?f s) (?f t))"
proof (intro ordered_powerprod.intro ordered_powerprod_axioms.intro)
show "class.linorder (λs t. le_of_nat_term_order cmp_term (?f s) (?f t))
(λs t. lt_of_nat_term_order cmp_term (?f s) (?f t))"
proof (unfold_locales, simp_all add: lt_of_nat_term_order_alt le_of_nat_term_order_alt ko.linear ko.less_le_not_le)
fix x y
assume "ko.le (key_order_of_nat_term_order_inv cmp_term) (term_of_pair (x, the_min)) (term_of_pair (y, the_min))"
and "ko.le (key_order_of_nat_term_order_inv cmp_term) (term_of_pair (y, the_min)) (term_of_pair (x, the_min))"
hence "term_of_pair (x, the_min) = term_of_pair (y, the_min)" by (rule ko.antisym)
hence "(x, the_min) = (y, the_min::'k)" by (rule tp.term_of_pair_injective)
thus "x = y" by simp
qed
next
fix t
show "le_of_nat_term_order cmp_term (?f 0) (?f t)"
unfolding le_of_nat_term_order
by (rule nat_term_compD1', fact comparator_nat_term_compare, fact nat_term_comp_nat_term_compare,
simp add: assms(3), simp add: assms(2) zero_pp tp.pair_term)
next
fix s t u
assume "le_of_nat_term_order cmp_term (?f s) (?f t)"
hence "le_of_nat_term_order cmp_term (?f (u + s)) (?f (u + t))"
by (simp add: le_of_nat_term_order assms(5) nat_term_compare_splus)
thus "le_of_nat_term_order cmp_term (?f (s + u)) (?f (t + u))" by (simp only: ac_simps)
qed
next
show "class.linorder (le_of_nat_term_order cmp_term) (lt_of_nat_term_order cmp_term)"
by (fact linorder_le_of_nat_term_order)
next
show "ordered_term_axioms pair_of_term term_of_pair (λs t. le_of_nat_term_order cmp_term (?f s) (?f t))
(le_of_nat_term_order cmp_term)"
proof
fix v w t
assume "le_of_nat_term_order cmp_term v w"
thus "le_of_nat_term_order cmp_term (t ⊕ v) (t ⊕ w)"
by (simp add: le_of_nat_term_order assms(6) nat_term_compare_splus)
next
fix v w
assume "le_of_nat_term_order cmp_term (?f (tp.pp_of_term v)) (?f (tp.pp_of_term w))"
hence 3: "nat_term_compare cmp_term (?f (tp.pp_of_term v)) (?f (tp.pp_of_term w)) ≠ Gt"
by (simp add: le_of_nat_term_order)
assume "tp.component_of_term v ≤ tp.component_of_term w"
hence 4: "snd (rep_nat_term v) ≤ snd (rep_nat_term w)"
by (simp add: tp.component_of_term_def assms(4))
note comparator_nat_term_compare nat_term_comp_nat_term_compare
moreover have "fst (rep_nat_term v) = fst (rep_nat_term (?f (tp.pp_of_term v)))"
by (simp add: assms(2) tp.pp_of_term_def tp.pair_term)
moreover have "fst (rep_nat_term w) = fst (rep_nat_term (?f (tp.pp_of_term w)))"
by (simp add: assms(2) tp.pp_of_term_def tp.pair_term)
moreover note 4
moreover have "snd (rep_nat_term (?f (tp.pp_of_term v))) = snd (rep_nat_term (?f (tp.pp_of_term w)))"
by (simp add: assms(3))
ultimately show "le_of_nat_term_order cmp_term v w" unfolding le_of_nat_term_order using 3
by (rule nat_term_compD4'')
qed
qed
qed
lemma gd_term_to_pair_unit:
"gd_term (to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod} ⇒ _) fst
(λs t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
(λs t. lt_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
(le_of_nat_term_order cmp_term)
(lt_of_nat_term_order cmp_term)"
proof (intro gd_term.intro ordered_term.intro)
show "term_powerprod to_pair_unit fst" by unfold_locales
next
show "ordered_powerprod (λs t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
(λs t. lt_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))"
unfolding fst_conv using linorder_le_of_nat_term_order
proof (intro ordered_powerprod.intro)
from le_of_nat_term_order_zero_min show "ordered_powerprod_axioms (le_of_nat_term_order cmp_term)"
proof (unfold_locales)
fix s t u
assume "le_of_nat_term_order cmp_term s t"
hence "le_of_nat_term_order cmp_term (u + s) (u + t)" by (rule le_of_nat_term_order_plus_monotone)
thus "le_of_nat_term_order cmp_term (s + u) (t + u)" by (simp only: ac_simps)
qed
qed
next
show "class.linorder (le_of_nat_term_order cmp_term) (lt_of_nat_term_order cmp_term)"
by (fact linorder_le_of_nat_term_order)
next
show "ordered_term_axioms to_pair_unit fst (λs t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
(le_of_nat_term_order cmp_term)" by (unfold_locales, auto intro: le_of_nat_term_order_plus_monotone)
qed
corollary gd_nat_term_to_pair_unit:
"gd_nat_term (to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod} ⇒ _) fst cmp_term"
by (rule gd_nat_term.intro, fact gd_term_to_pair_unit, rule gd_nat_term_axioms.intro, simp add: splus_pp_term)
lemma gd_term_id:
"gd_term (λx::('a::{nat_term_compare,nat_pp_compare,nat_pp_term,graded_dickson_powerprod} × 'b::{nat,the_min}). x) (λx. x)
(λs t. le_of_nat_term_order cmp_term (s, the_min) (t, the_min))
(λs t. lt_of_nat_term_order cmp_term (s, the_min) (t, the_min))
(le_of_nat_term_order cmp_term)
(lt_of_nat_term_order cmp_term)"
apply (rule term_powerprod_gd_term)
subgoal by unfold_locales
subgoal by (simp add: rep_nat_term_prod_def)
subgoal by (simp add: rep_nat_term_prod_def the_min_eq_zero)
subgoal by (simp add: rep_nat_term_prod_def ord_iff[symmetric])
subgoal by (simp add: splus_prod_def pprod.splus_def)
subgoal by (simp add: splus_prod_def)
done
corollary gd_nat_term_id: "gd_nat_term (λx. x) (λx. x) cmp_term"
for cmp_term :: "('a::{nat_term_compare,nat_pp_compare,nat_pp_term,graded_dickson_powerprod} × 'c::{nat,the_min}) nat_term_order"
by (rule gd_nat_term.intro, fact gd_term_id, rule gd_nat_term_axioms.intro, simp add: splus_prod_def)
subsection ‹Computations›
type_synonym 'a mpoly_tc = "(nat, nat) pp ⇒⇩0 'a"
global_interpretation punit0: gd_nat_term "to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod} ⇒ _" fst cmp_term
rewrites "punit.adds_term = (adds)"
and "punit.pp_of_term = (λx. x)"
and "punit.component_of_term = (λ_. ())"
for cmp_term
defines monom_mult_punit = punit.monom_mult
and mult_scalar_punit = punit.mult_scalar
and shift_map_keys_punit = punit0.shift_map_keys
and ord_pp_punit = punit0.ord_pp
and ord_pp_strict_punit = punit0.ord_pp_strict
and min_term_punit = punit0.min_term
and lt_punit = punit0.lt
and lc_punit = punit0.lc
and tail_punit = punit0.tail
and comp_opt_p_punit = punit0.comp_opt_p
and ord_p_punit = punit0.ord_p
and ord_strict_p_punit = punit0.ord_strict_p
and keys_to_list_punit = punit0.keys_to_list
subgoal by (fact gd_nat_term_to_pair_unit)
subgoal by (fact punit_adds_term)
subgoal by (fact punit_pp_of_term)
subgoal by (fact punit_component_of_term)
done
lemma shift_map_keys_punit_MP_oalist [code abstract]:
"list_of_oalist_ntm (shift_map_keys_punit t f xs) = map_raw (λ(k, v). (t + k, f v)) (list_of_oalist_ntm xs)"
by (simp add: punit0.list_of_oalist_shift_keys case_prod_beta')
lemmas [code] = punit0.mult_scalar_MP_oalist[unfolded mult_scalar_punit_def punit_mult_scalar]
punit0.punit_min_term
lemma ord_pp_punit_alt [code_unfold]: "ord_pp_punit = le_of_nat_term_order"
by (intro ext, simp add: punit0.ord_pp_def)
lemma ord_pp_strict_punit_alt [code_unfold]: "ord_pp_strict_punit = lt_of_nat_term_order"
by (intro ext, simp add: punit0.ord_pp_strict_def)
lemma gd_powerprod_ord_pp_punit: "gd_powerprod (ord_pp_punit cmp_term) (ord_pp_strict_punit cmp_term)"
unfolding punit0.ord_pp_def punit0.ord_pp_strict_def ..
locale trivariate⇩0_rat
begin
abbreviation X::"rat mpoly_tc" where "X ≡ V⇩0 (0::nat)"
abbreviation Y::"rat mpoly_tc" where "Y ≡ V⇩0 (1::nat)"
abbreviation Z::"rat mpoly_tc" where "Z ≡ V⇩0 (2::nat)"
end
experiment begin interpretation trivariate⇩0_rat .
value [code] "X ^ 2"
value [code] "X⇧2 * Z + 2 * Y ^ 3 * Z⇧2"
value [code] "distr⇩0 DRLEX [(sparse⇩0 [(0::nat, 3::nat)], 1::rat)] = distr⇩0 DRLEX [(sparse⇩0 [(0, 3)], 1)]"
lemma
"ord_strict_p_punit DRLEX (X⇧2 * Z + 2 * Y ^ 3 * Z⇧2) (X⇧2 * Z⇧2 + 2 * Y ^ 3 * Z⇧2)"
by eval
lemma
"tail_punit DLEX (X⇧2 * Z + 2 * Y ^ 3 * Z⇧2) = X⇧2 * Z"
by eval
value [code] "min_term_punit::(nat, nat) pp"
value [code] "is_zero (distr⇩0 DRLEX [(sparse⇩0 [(0::nat, 3::nat)], 1::rat)])"
value [code] "lt_punit DRLEX (distr⇩0 DRLEX [(sparse⇩0 [(0::nat, 3::nat)], 1::rat)])"
lemma
"lt_punit DRLEX (X⇧2 * Z + 2 * Y ^ 3 * Z⇧2) = sparse⇩0 [(1, 3), (2, 2)]"
by eval
lemma
"lt_punit DRLEX (X + Y + Z) = sparse⇩0 [(2, 1)]"
by eval
lemma
"keys (X⇧2 * Z ^ 3 + 2 * Y ^ 3 * Z⇧2) =
{sparse⇩0 [(0, 2), (2, 3)], sparse⇩0 [(1, 3), (2, 2)]}"
by eval
lemma
"- 1 * X⇧2 * Z ^ 7 + - 2 * Y ^ 3 * Z⇧2 = - X⇧2 * Z ^ 7 + - 2 * Y ^ 3 * Z⇧2"
by eval
lemma
"X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2 + X⇧2 * Z ^ 4 + - 2 * Y ^ 3 * Z⇧2 = X⇧2 * Z ^ 7 + X⇧2 * Z ^ 4"
by eval
lemma
"X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2 - X⇧2 * Z ^ 4 + - 2 * Y ^ 3 * Z⇧2 =
X⇧2 * Z ^ 7 - X⇧2 * Z ^ 4"
by eval
lemma
"lookup (X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2 + 2) (sparse⇩0 [(0, 2), (2, 7)]) = 1"
by eval
lemma
"X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2 ≠
X⇧2 * Z ^ 4 + - 2 * Y ^ 3 * Z⇧2"
by eval
lemma
"0 * X^2 * Z^7 + 0 * Y^3*Z⇧2 = 0"
by eval
lemma
"monom_mult_punit 3 (sparse⇩0 [(1, 2::nat)]) (X⇧2 * Z + 2 * Y ^ 3 * Z⇧2) =
3 * Y⇧2 * Z * X⇧2 + 6 * Y ^ 5 * Z⇧2"
by eval
lemma
"monomial (-4) (sparse⇩0 [(0, 2::nat)]) = - 4 * X⇧2"
by eval
lemma "monomial (0::rat) (sparse⇩0 [(0::nat, 2::nat)]) = 0"
by eval
lemma
"(X⇧2 * Z + 2 * Y ^ 3 * Z⇧2) * (X⇧2 * Z ^ 3 + - 2 * Y ^ 3 * Z⇧2) =
X ^ 4 * Z ^ 4 + - 2 * X⇧2 * Z ^ 3 * Y ^ 3 +
- 4 * Y ^ 6 * Z ^ 4 + 2 * Y ^ 3 * Z ^ 5 * X⇧2"
by eval
end
subsection ‹Code setup for type MPoly›
text ‹postprocessing from ‹Var⇩0, Const⇩0› to ‹Var, Const›.›
lemmas [code_post] =
plus_mpoly.abs_eq[symmetric]
times_mpoly.abs_eq[symmetric]
one_mpoly_def[symmetric]
Var.abs_eq[symmetric]
Const.abs_eq[symmetric]
instantiation mpoly::("{equal, zero}")equal begin
lift_definition equal_mpoly:: "'a mpoly ⇒ 'a mpoly ⇒ bool" is HOL.equal .
instance proof standard qed (transfer, rule equal_eq)
end
end
Theory Quasi_PM_Power_Products
section ‹Quasi-Poly-Mapping Power-Products›
theory Quasi_PM_Power_Products
imports MPoly_Type_Class_Ordered
begin
text ‹In this theory we introduce a subclass of @{class graded_dickson_powerprod} that approximates
polynomial mappings even closer. We need this class for signature-based Gr\"obner basis algorithms.›
definition (in monoid_add) hom_grading_fun :: "('a ⇒ nat) ⇒ (nat ⇒ 'a ⇒ 'a) ⇒ bool"
where "hom_grading_fun d f ⟷ (∀n. (∀s t. f n (s + t) = f n s + f n t) ∧
(∀t. d (f n t) ≤ n ∧ (d t ≤ n ⟶ f n t = t)))"
definition (in monoid_add) hom_grading :: "('a ⇒ nat) ⇒ bool"
where "hom_grading d ⟷ (∃f. hom_grading_fun d f)"
definition (in monoid_add) decr_grading :: "('a ⇒ nat) ⇒ nat ⇒ 'a ⇒ 'a"
where "decr_grading d = (SOME f. hom_grading_fun d f)"
lemma decr_grading:
assumes "hom_grading d"
shows "hom_grading_fun d (decr_grading d)"
proof -
from assms obtain f where "hom_grading_fun d f" unfolding hom_grading_def ..
thus ?thesis unfolding decr_grading_def by (metis someI)
qed
lemma decr_grading_plus:
"hom_grading d ⟹ decr_grading d n (s + t) = decr_grading d n s + decr_grading d n t"
using decr_grading unfolding hom_grading_fun_def by blast
lemma decr_grading_zero:
assumes "hom_grading d"
shows "decr_grading d n 0 = (0::'a::cancel_comm_monoid_add)"
proof -
have "decr_grading d n 0 = decr_grading d n (0 + 0)" by simp
also from assms have "... = decr_grading d n 0 + decr_grading d n 0" by (rule decr_grading_plus)
finally show ?thesis by simp
qed
lemma decr_grading_le: "hom_grading d ⟹ d (decr_grading d n t) ≤ n"
using decr_grading unfolding hom_grading_fun_def by blast
lemma decr_grading_idI: "hom_grading d ⟹ d t ≤ n ⟹ decr_grading d n t = t"
using decr_grading unfolding hom_grading_fun_def by blast
class quasi_pm_powerprod = ulcs_powerprod +
assumes ex_hgrad: "∃d::'a ⇒ nat. dickson_grading d ∧ hom_grading d"
begin
subclass graded_dickson_powerprod
proof
from ex_hgrad show "∃d. dickson_grading d" by blast
qed
end
lemma hom_grading_varnum:
"hom_grading ((varnum X)::('x::countable ⇒⇩0 'b::add_wellorder) ⇒ nat)"
proof -
define f where "f = (λn t. (except t (- (X ∪ {x. elem_index x < n})))::'x ⇒⇩0 'b)"
show ?thesis unfolding hom_grading_def hom_grading_fun_def
proof (intro exI allI conjI impI)
fix n s t
show "f n (s + t) = f n s + f n t" by (simp only: f_def except_plus)
next
fix n t
show "varnum X (f n t) ≤ n" by (auto simp: varnum_le_iff keys_except f_def)
next
fix n t
show "varnum X t ≤ n ⟹ f n t = t" by (auto simp: f_def except_id_iff varnum_le_iff)
qed
qed
instance poly_mapping :: (countable, add_wellorder) quasi_pm_powerprod
by (standard, intro exI conjI, fact dickson_grading_varnum_empty, fact hom_grading_varnum)
context term_powerprod
begin
definition decr_grading_term :: "('a ⇒ nat) ⇒ nat ⇒ 't ⇒ 't"
where "decr_grading_term d n v = term_of_pair (decr_grading d n (pp_of_term v), component_of_term v)"
definition decr_grading_p :: "('a ⇒ nat) ⇒ nat ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::comm_monoid_add)"
where "decr_grading_p d n p = (∑v∈keys p. monomial (lookup p v) (decr_grading_term d n v))"
lemma decr_grading_term_splus:
"hom_grading d ⟹ decr_grading_term d n (t ⊕ v) = decr_grading d n t ⊕ decr_grading_term d n v"
by (simp add: decr_grading_term_def term_simps decr_grading_plus splus_def)
lemma decr_grading_term_le: "hom_grading d ⟹ d (pp_of_term (decr_grading_term d n v)) ≤ n"
by (simp add: decr_grading_term_def term_simps decr_grading_le)
lemma decr_grading_term_idI: "hom_grading d ⟹ d (pp_of_term v) ≤ n ⟹ decr_grading_term d n v = v"
by (simp add: decr_grading_term_def term_simps decr_grading_idI)
lemma punit_decr_grading_term: "punit.decr_grading_term = decr_grading"
by (intro ext, simp add: punit.decr_grading_term_def)
lemma decr_grading_p_zero: "decr_grading_p d n 0 = 0"
by (simp add: decr_grading_p_def)
lemma decr_grading_p_monomial: "decr_grading_p d n (monomial c v) = monomial c (decr_grading_term d n v)"
by (simp add: decr_grading_p_def)
lemma decr_grading_p_plus:
"decr_grading_p d n (p + q) = (decr_grading_p d n p) + (decr_grading_p d n q)"
proof -
from finite_keys finite_keys have fin: "finite (keys p ∪ keys q)" by (rule finite_UnI)
hence eq1: "(∑v∈keys p ∪ keys q. monomial (lookup p v) (decr_grading_term d n v)) =
(∑v∈keys p. monomial (lookup p v) (decr_grading_term d n v))"
proof (rule sum.mono_neutral_right)
show "∀v∈keys p ∪ keys q - keys p. monomial (lookup p v) (decr_grading_term d n v) = 0"
by (simp add: in_keys_iff)
qed simp
from fin have eq2: "(∑v∈keys p ∪ keys q. monomial (lookup q v) (decr_grading_term d n v)) =
(∑v∈keys q. monomial (lookup q v) (decr_grading_term d n v))"
proof (rule sum.mono_neutral_right)
show "∀v∈keys p ∪ keys q - keys q. monomial (lookup q v) (decr_grading_term d n v) = 0"
by (simp add: in_keys_iff)
qed simp
from fin Poly_Mapping.keys_add
have "decr_grading_p d n (p + q) =
(∑v∈keys p ∪ keys q. monomial (lookup (p + q) v) (decr_grading_term d n v))"
unfolding decr_grading_p_def
proof (rule sum.mono_neutral_left)
show "∀v∈keys p ∪ keys q - keys (p + q). monomial (lookup (p + q) v) (decr_grading_term d n v) = 0"
by (simp add: in_keys_iff)
qed
also have "... = (∑v∈keys p ∪ keys q. monomial (lookup p v) (decr_grading_term d n v)) +
(∑v∈keys p ∪ keys q. monomial (lookup q v) (decr_grading_term d n v))"
by (simp only: lookup_add single_add sum.distrib)
also have "... = (decr_grading_p d n p) + (decr_grading_p d n q)"
by (simp only: eq1 eq2 decr_grading_p_def)
finally show ?thesis .
qed
corollary decr_grading_p_sum: "decr_grading_p d n (sum f A) = (∑a∈A. decr_grading_p d n (f a))"
using decr_grading_p_zero decr_grading_p_plus by (rule fun_sum_commute)
lemma decr_grading_p_monom_mult:
assumes "hom_grading d"
shows "decr_grading_p d n (monom_mult c t p) = monom_mult c (decr_grading d n t) (decr_grading_p d n p)"
proof (induct p rule: poly_mapping_plus_induct)
case 1
show ?case by (simp add: decr_grading_p_zero)
next
case (2 p a s)
from assms show ?case
by (simp add: monom_mult_dist_right decr_grading_p_plus 2(3) monom_mult_monomial
decr_grading_p_monomial decr_grading_term_splus)
qed
lemma decr_grading_p_mult_scalar:
assumes "hom_grading d"
shows "decr_grading_p d n (p ⊙ q) = punit.decr_grading_p d n p ⊙ decr_grading_p d n q"
proof (induct p rule: poly_mapping_plus_induct)
case 1
show ?case by (simp add: punit.decr_grading_p_zero decr_grading_p_zero)
next
case (2 p a s)
from assms show ?case
by (simp add: mult_scalar_distrib_right decr_grading_p_plus punit.decr_grading_p_plus 2(3)
punit.decr_grading_p_monomial mult_scalar_monomial decr_grading_p_monom_mult punit_decr_grading_term)
qed
lemma decr_grading_p_keys_subset: "keys (decr_grading_p d n p) ⊆ decr_grading_term d n ` keys p"
proof
fix v
assume "v ∈ keys (decr_grading_p d n p)"
also have "... ⊆ (⋃u∈keys p. keys (monomial (lookup p u) (decr_grading_term d n u)))"
unfolding decr_grading_p_def by (fact keys_sum_subset)
finally obtain u where "u ∈ keys p" and "v ∈ keys (monomial (lookup p u) (decr_grading_term d n u))" ..
from this(2) have eq: "v = decr_grading_term d n u" by (simp split: if_split_asm)
show "v ∈ decr_grading_term d n ` keys p" unfolding eq using ‹u ∈ keys p› by (rule imageI)
qed
lemma decr_grading_p_idI':
assumes "hom_grading d" and "⋀v. v ∈ keys p ⟹ d (pp_of_term v) ≤ n"
shows "decr_grading_p d n p = p"
proof -
have "decr_grading_p d n p = (∑v ∈ keys p. monomial (lookup p v) v)" unfolding decr_grading_p_def
using refl
proof (rule sum.cong)
fix v
assume "v ∈ keys p"
hence "d (pp_of_term v) ≤ n" by (rule assms(2))
with assms(1) have "decr_grading_term d n v = v" by (rule decr_grading_term_idI)
thus "monomial (lookup p v) (decr_grading_term d n v) = monomial (lookup p v) v" by simp
qed
also have "... = p" by (fact poly_mapping_sum_monomials)
finally show ?thesis .
qed
end
context gd_term
begin
lemma decr_grading_p_idI:
assumes "hom_grading d" and "p ∈ dgrad_p_set d m"
shows "decr_grading_p d m p = p"
proof -
from assms(2) have "⋀v. v ∈ keys p ⟹ d (pp_of_term v) ≤ m"
by (auto simp: dgrad_p_set_def dgrad_set_def)
with assms(1) show ?thesis by (rule decr_grading_p_idI')
qed
lemma decr_grading_p_dgrad_p_setI:
assumes "hom_grading d"
shows "decr_grading_p d m p ∈ dgrad_p_set d m"
proof (rule dgrad_p_setI)
fix v
assume "v ∈ keys (decr_grading_p d m p)"
hence "v ∈ decr_grading_term d m ` keys p" using decr_grading_p_keys_subset ..
then obtain u where "v = decr_grading_term d m u" ..
with assms show "d (pp_of_term v) ≤ m" by (simp add: decr_grading_term_le)
qed
lemma (in gd_term) in_pmdlE_dgrad_p_set:
assumes "hom_grading d" and "B ⊆ dgrad_p_set d m" and "p ∈ dgrad_p_set d m" and "p ∈ pmdl B"
obtains A q where "finite A" and "A ⊆ B" and "⋀b. q b ∈ punit.dgrad_p_set d m"
and "p = (∑b∈A. q b ⊙ b)"
proof -
from assms(4) obtain A q0 where "finite A" and "A ⊆ B" and p: "p = (∑b∈A. q0 b ⊙ b)"
by (rule pmdl.spanE)
define q where "q = (λb. punit.decr_grading_p d m (q0 b))"
from ‹finite A› ‹A ⊆ B› show ?thesis
proof
fix b
show "q b ∈ punit.dgrad_p_set d m" unfolding q_def using assms(1) by (rule punit.decr_grading_p_dgrad_p_setI)
next
from assms(1, 3) have "p = decr_grading_p d m p" by (simp only: decr_grading_p_idI)
also from assms(1) have "... = (∑b∈A. q b ⊙ (decr_grading_p d m b))"
by (simp add: p q_def decr_grading_p_sum decr_grading_p_mult_scalar)
also from refl have "... = (∑b∈A. q b ⊙ b)"
proof (rule sum.cong)
fix b
assume "b ∈ A"
hence "b ∈ B" using ‹A ⊆ B› ..
hence "b ∈ dgrad_p_set d m" using assms(2) ..
with assms(1) have "decr_grading_p d m b = b" by (rule decr_grading_p_idI)
thus "q b ⊙ decr_grading_p d m b = q b ⊙ b" by simp
qed
finally show "p = (∑b∈A. q b ⊙ b)" .
qed
qed
end
end
Theory MPoly_PM
section ‹Multivariate Polynomials with Power-Products Represented by Polynomial Mappings›
theory MPoly_PM
imports Quasi_PM_Power_Products
begin
text ‹Many notions introduced in this theory for type @{typ "('x ⇒⇩0 'a) ⇒⇩0 'b"} closely resemble
those introduced in @{theory Polynomials.MPoly_Type} for type @{typ "'a mpoly"}.›
lemma monomial_single_power:
"(monomial c (Poly_Mapping.single x k)) ^ n = monomial (c ^ n) (Poly_Mapping.single x (k * n))"
proof -
have eq: "(∑i = 0..<n. Poly_Mapping.single x k) = Poly_Mapping.single x (k * n)"
by (induct n, simp_all add: add.commute single_add)
show ?thesis by (simp add: punit.monomial_power eq)
qed
lemma monomial_power_map_scale: "(monomial c t) ^ n = monomial (c ^ n) (n ⋅ t)"
proof -
have "(∑i = 0..<n. t) = (∑i = 0..<n. 1) ⋅ t"
by (simp only: map_scale_sum_distrib_right map_scale_one_left)
thus ?thesis by (simp add: punit.monomial_power)
qed
lemma times_canc_left:
assumes "h * p = h * q" and "h ≠ (0::('x::linorder ⇒⇩0 nat) ⇒⇩0 'a::ring_no_zero_divisors)"
shows "p = q"
proof (rule ccontr)
assume "p ≠ q"
hence "p - q ≠ 0" by simp
with assms(2) have "h * (p - q) ≠ 0" by simp
hence "h * p ≠ h * q" by (simp add: algebra_simps)
thus False using assms(1) ..
qed
lemma times_canc_right:
assumes "p * h = q * h" and "h ≠ (0::('x::linorder ⇒⇩0 nat) ⇒⇩0 'a::ring_no_zero_divisors)"
shows "p = q"
proof (rule ccontr)
assume "p ≠ q"
hence "p - q ≠ 0" by simp
hence "(p - q) * h ≠ 0" using assms(2) by simp
hence "p * h ≠ q * h" by (simp add: algebra_simps)
thus False using assms(1) ..
qed
subsection ‹Degree›
lemma plus_minus_assoc_pm_nat_1: "s + t - u = (s - (u - t)) + (t - (u::_ ⇒⇩0 nat))"
by (rule poly_mapping_eqI, simp add: lookup_add lookup_minus)
lemma plus_minus_assoc_pm_nat_2:
"s + (t - u) = (s + (except (u - t) (- keys s))) + t - (u::_ ⇒⇩0 nat)"
proof (rule poly_mapping_eqI)
fix x
show "lookup (s + (t - u)) x = lookup (s + except (u - t) (- keys s) + t - u) x"
proof (cases "x ∈ keys s")
case True
thus ?thesis
by (simp add: plus_minus_assoc_pm_nat_1 lookup_add lookup_minus lookup_except)
next
case False
hence "lookup s x = 0" by (simp add: in_keys_iff)
with False show ?thesis
by (simp add: lookup_add lookup_minus lookup_except)
qed
qed
lemma deg_pm_sum: "deg_pm (sum t A) = (∑a∈A. deg_pm (t a))"
by (induct A rule: infinite_finite_induct) (auto simp: deg_pm_plus)
lemma deg_pm_mono: "s adds t ⟹ deg_pm s ≤ deg_pm (t::_ ⇒⇩0 _::add_linorder_min)"
by (metis addsE deg_pm_plus le_iff_add)
lemma adds_deg_pm_antisym: "s adds t ⟹ deg_pm t ≤ deg_pm (s::_ ⇒⇩0 _::add_linorder_min) ⟹ s = t"
by (metis (no_types, lifting) add.right_neutral add.right_neutral add_left_cancel addsE
deg_pm_eq_0_iff deg_pm_mono deg_pm_plus dual_order.antisym)
lemma deg_pm_minus:
assumes "s adds (t::_ ⇒⇩0 _::comm_monoid_add)"
shows "deg_pm (t - s) = deg_pm t - deg_pm s"
proof -
from assms have "(t - s) + s = t" by (rule adds_minus)
hence "deg_pm t = deg_pm ((t - s) + s)" by simp
also have "… = deg_pm (t - s) + deg_pm s" by (simp only: deg_pm_plus)
finally show ?thesis by simp
qed
lemma adds_group [simp]: "s adds (t::'a ⇒⇩0 'b::ab_group_add)"
proof (rule addsI)
show "t = s + (t - s)" by simp
qed
lemmas deg_pm_minus_group = deg_pm_minus[OF adds_group]
lemma deg_pm_minus_le: "deg_pm (t - s) ≤ deg_pm (t::_ ⇒⇩0 nat)"
proof -
have "keys (t - s) ⊆ keys t" by (rule, simp add: lookup_minus in_keys_iff)
hence "deg_pm (t - s) = (∑x∈keys t. lookup (t - s) x)" using finite_keys by (rule deg_pm_superset)
also have "… ≤ (∑x∈keys t. lookup t x)" by (rule sum_mono) (simp add: lookup_minus)
also have "… = deg_pm t" by (rule sym, rule deg_pm_superset, fact subset_refl, fact finite_keys)
finally show ?thesis .
qed
lemma minus_id_iff: "t - s = t ⟷ keys t ∩ keys (s::_ ⇒⇩0 nat) = {}"
proof
assume "t - s = t"
{
fix x
assume "x ∈ keys t" and "x ∈ keys s"
hence "0 < lookup t x" and "0 < lookup s x" by (simp_all add: in_keys_iff)
hence "lookup (t - s) x ≠ lookup t x" by (simp add: lookup_minus)
with ‹t - s = t› have False by simp
}
thus "keys t ∩ keys s = {}" by blast
next
assume *: "keys t ∩ keys s = {}"
show "t - s = t"
proof (rule poly_mapping_eqI)
fix x
have "lookup t x - lookup s x = lookup t x"
proof (cases "x ∈ keys t")
case True
with * have "x ∉ keys s" by blast
thus ?thesis by (simp add: in_keys_iff)
next
case False
thus ?thesis by (simp add: in_keys_iff)
qed
thus "lookup (t - s) x = lookup t x" by (simp only: lookup_minus)
qed
qed
lemma deg_pm_minus_id_iff: "deg_pm (t - s) = deg_pm t ⟷ keys t ∩ keys (s::_ ⇒⇩0 nat) = {}"
proof
assume eq: "deg_pm (t - s) = deg_pm t"
{
fix x
assume "x ∈ keys t" and "x ∈ keys s"
hence "0 < lookup t x" and "0 < lookup s x" by (simp_all add: in_keys_iff)
hence *: "lookup (t - s) x < lookup t x" by (simp add: lookup_minus)
have "keys (t - s) ⊆ keys t" by (rule, simp add: lookup_minus in_keys_iff)
hence "deg_pm (t - s) = (∑x∈keys t. lookup (t - s) x)" using finite_keys by (rule deg_pm_superset)
also from finite_keys have "… < (∑x∈keys t. lookup t x)"
proof (rule sum_strict_mono_ex1)
show "∀x∈keys t. lookup (t - s) x ≤ lookup t x" by (simp add: lookup_minus)
next
from ‹x ∈ keys t› * show "∃x∈keys t. lookup (t - s) x < lookup t x" ..
qed
also have "… = deg_pm t" by (rule sym, rule deg_pm_superset, fact subset_refl, fact finite_keys)
finally have False by (simp add: eq)
}
thus "keys t ∩ keys s = {}" by blast
next
assume "keys t ∩ keys s = {}"
hence "t - s = t" by (simp only: minus_id_iff)
thus "deg_pm (t - s) = deg_pm t" by (simp only:)
qed
definition poly_deg :: "(('x ⇒⇩0 'a::add_linorder) ⇒⇩0 'b::zero) ⇒ 'a" where
"poly_deg p = (if keys p = {} then 0 else Max (deg_pm ` keys p))"
definition maxdeg :: "(('x ⇒⇩0 'a::add_linorder) ⇒⇩0 'b::zero) set ⇒ 'a" where
"maxdeg A = Max (poly_deg ` A)"
definition mindeg :: "(('x ⇒⇩0 'a::add_linorder) ⇒⇩0 'b::zero) set ⇒ 'a" where
"mindeg A = Min (poly_deg ` A)"
lemma poly_deg_monomial: "poly_deg (monomial c t) = (if c = 0 then 0 else deg_pm t)"
by (simp add: poly_deg_def)
lemma poly_deg_monomial_zero [simp]: "poly_deg (monomial c 0) = 0"
by (simp add: poly_deg_monomial)
lemma poly_deg_zero [simp]: "poly_deg 0 = 0"
by (simp only: single_zero[of 0, symmetric] poly_deg_monomial_zero)
lemma poly_deg_one [simp]: "poly_deg 1 = 0"
by (simp only: single_one[symmetric] poly_deg_monomial_zero)
lemma poly_degE:
assumes "p ≠ 0"
obtains t where "t ∈ keys p" and "poly_deg p = deg_pm t"
proof -
from assms have "poly_deg p = Max (deg_pm ` keys p)" by (simp add: poly_deg_def)
also have "… ∈ deg_pm ` keys p"
proof (rule Max_in)
from assms show "deg_pm ` keys p ≠ {}" by simp
qed simp
finally obtain t where "t ∈ keys p" and "poly_deg p = deg_pm t" ..
thus ?thesis ..
qed
lemma poly_deg_max_keys: "t ∈ keys p ⟹ deg_pm t ≤ poly_deg p"
using finite_keys by (auto simp: poly_deg_def)
lemma poly_deg_leI: "(⋀t. t ∈ keys p ⟹ deg_pm t ≤ (d::'a::add_linorder_min)) ⟹ poly_deg p ≤ d"
using finite_keys by (auto simp: poly_deg_def)
lemma poly_deg_lessI:
"p ≠ 0 ⟹ (⋀t. t ∈ keys p ⟹ deg_pm t < (d::'a::add_linorder_min)) ⟹ poly_deg p < d"
using finite_keys by (auto simp: poly_deg_def)
lemma poly_deg_zero_imp_monomial:
assumes "poly_deg p = (0::'a::add_linorder_min)"
shows "monomial (lookup p 0) 0 = p"
proof (rule keys_subset_singleton_imp_monomial, rule)
fix t
assume "t ∈ keys p"
have "t = 0"
proof (rule ccontr)
assume "t ≠ 0"
hence "deg_pm t ≠ 0" by simp
hence "0 < deg_pm t" using not_gr_zero by blast
also from ‹t ∈ keys p› have "... ≤ poly_deg p" by (rule poly_deg_max_keys)
finally have "poly_deg p ≠ 0" by simp
from this assms show False ..
qed
thus "t ∈ {0}" by simp
qed
lemma poly_deg_plus_le:
"poly_deg (p + q) ≤ max (poly_deg p) (poly_deg (q::(_ ⇒⇩0 'a::add_linorder_min) ⇒⇩0 _))"
proof (rule poly_deg_leI)
fix t
assume "t ∈ keys (p + q)"
also have "... ⊆ keys p ∪ keys q" by (fact Poly_Mapping.keys_add)
finally show "deg_pm t ≤ max (poly_deg p) (poly_deg q)"
proof
assume "t ∈ keys p"
hence "deg_pm t ≤ poly_deg p" by (rule poly_deg_max_keys)
thus ?thesis by (simp add: le_max_iff_disj)
next
assume "t ∈ keys q"
hence "deg_pm t ≤ poly_deg q" by (rule poly_deg_max_keys)
thus ?thesis by (simp add: le_max_iff_disj)
qed
qed
lemma poly_deg_uminus [simp]: "poly_deg (-p) = poly_deg p"
by (simp add: poly_deg_def keys_uminus)
lemma poly_deg_minus_le:
"poly_deg (p - q) ≤ max (poly_deg p) (poly_deg (q::(_ ⇒⇩0 'a::add_linorder_min) ⇒⇩0 _))"
proof (rule poly_deg_leI)
fix t
assume "t ∈ keys (p - q)"
also have "... ⊆ keys p ∪ keys q" by (fact keys_minus)
finally show "deg_pm t ≤ max (poly_deg p) (poly_deg q)"
proof
assume "t ∈ keys p"
hence "deg_pm t ≤ poly_deg p" by (rule poly_deg_max_keys)
thus ?thesis by (simp add: le_max_iff_disj)
next
assume "t ∈ keys q"
hence "deg_pm t ≤ poly_deg q" by (rule poly_deg_max_keys)
thus ?thesis by (simp add: le_max_iff_disj)
qed
qed
lemma poly_deg_times_le:
"poly_deg (p * q) ≤ poly_deg p + poly_deg (q::(_ ⇒⇩0 'a::add_linorder_min) ⇒⇩0 _)"
proof (rule poly_deg_leI)
fix t
assume "t ∈ keys (p * q)"
then obtain u v where "u ∈ keys p" and "v ∈ keys q" and "t = u + v" by (rule in_keys_timesE)
from ‹u ∈ keys p› have "deg_pm u ≤ poly_deg p" by (rule poly_deg_max_keys)
moreover from ‹v ∈ keys q› have "deg_pm v ≤ poly_deg q" by (rule poly_deg_max_keys)
ultimately show "deg_pm t ≤ poly_deg p + poly_deg q" by (simp add: ‹t = u + v› deg_pm_plus add_mono)
qed
lemma poly_deg_times:
assumes "p ≠ 0" and "q ≠ (0::('x::linorder ⇒⇩0 'a::add_linorder_min) ⇒⇩0 'b::semiring_no_zero_divisors)"
shows "poly_deg (p * q) = poly_deg p + poly_deg q"
using poly_deg_times_le
proof (rule antisym)
let ?A = "λf. {u. deg_pm u < poly_deg f}"
define p1 where "p1 = except p (?A p)"
define p2 where "p2 = except p (- ?A p)"
define q1 where "q1 = except q (?A q)"
define q2 where "q2 = except q (- ?A q)"
have deg_p1: "deg_pm t = poly_deg p" if "t ∈ keys p1" for t
proof -
from that have "t ∈ keys p" and "poly_deg p ≤ deg_pm t"
by (simp_all add: p1_def keys_except not_less)
from this(1) have "deg_pm t ≤ poly_deg p" by (rule poly_deg_max_keys)
thus ?thesis using ‹poly_deg p ≤ deg_pm t› by (rule antisym)
qed
have deg_p2: "t ∈ keys p2 ⟹ deg_pm t < poly_deg p" for t by (simp add: p2_def keys_except)
have deg_q1: "deg_pm t = poly_deg q" if "t ∈ keys q1" for t
proof -
from that have "t ∈ keys q" and "poly_deg q ≤ deg_pm t"
by (simp_all add: q1_def keys_except not_less)
from this(1) have "deg_pm t ≤ poly_deg q" by (rule poly_deg_max_keys)
thus ?thesis using ‹poly_deg q ≤ deg_pm t› by (rule antisym)
qed
have deg_q2: "t ∈ keys q2 ⟹ deg_pm t < poly_deg q" for t by (simp add: q2_def keys_except)
have p: "p = p1 + p2" unfolding p1_def p2_def by (fact except_decomp)
have "p1 ≠ 0"
proof -
from assms(1) obtain t where "t ∈ keys p" and "poly_deg p = deg_pm t" by (rule poly_degE)
hence "t ∈ keys p1" by (simp add: p1_def keys_except)
thus ?thesis by auto
qed
have q: "q = q1 + q2" unfolding q1_def q2_def by (fact except_decomp)
have "q1 ≠ 0"
proof -
from assms(2) obtain t where "t ∈ keys q" and "poly_deg q = deg_pm t" by (rule poly_degE)
hence "t ∈ keys q1" by (simp add: q1_def keys_except)
thus ?thesis by auto
qed
with ‹p1 ≠ 0› have "p1 * q1 ≠ 0" by simp
hence "keys (p1 * q1) ≠ {}" by simp
then obtain u where "u ∈ keys (p1 * q1)" by blast
then obtain s t where "s ∈ keys p1" and "t ∈ keys q1" and u: "u = s + t" by (rule in_keys_timesE)
from ‹s ∈ keys p1› have "deg_pm s = poly_deg p" by (rule deg_p1)
moreover from ‹t ∈ keys q1› have "deg_pm t = poly_deg q" by (rule deg_q1)
ultimately have eq: "poly_deg p + poly_deg q = deg_pm u" by (simp only: u deg_pm_plus)
also have "… ≤ poly_deg (p * q)"
proof (rule poly_deg_max_keys)
have "u ∉ keys (p1 * q2 + p2 * q)"
proof
assume "u ∈ keys (p1 * q2 + p2 * q)"
also have "… ⊆ keys (p1 * q2) ∪ keys (p2 * q)" by (rule Poly_Mapping.keys_add)
finally have "deg_pm u < poly_deg p + poly_deg q"
proof
assume "u ∈ keys (p1 * q2)"
then obtain s' t' where "s' ∈ keys p1" and "t' ∈ keys q2" and u: "u = s' + t'"
by (rule in_keys_timesE)
from ‹s' ∈ keys p1› have "deg_pm s' = poly_deg p" by (rule deg_p1)
moreover from ‹t' ∈ keys q2› have "deg_pm t' < poly_deg q" by (rule deg_q2)
ultimately show ?thesis by (simp add: u deg_pm_plus)
next
assume "u ∈ keys (p2 * q)"
then obtain s' t' where "s' ∈ keys p2" and "t' ∈ keys q" and u: "u = s' + t'"
by (rule in_keys_timesE)
from ‹s' ∈ keys p2› have "deg_pm s' < poly_deg p" by (rule deg_p2)
moreover from ‹t' ∈ keys q› have "deg_pm t' ≤ poly_deg q" by (rule poly_deg_max_keys)
ultimately show ?thesis by (simp add: u deg_pm_plus add_less_le_mono)
qed
thus False by (simp only: eq)
qed
with ‹u ∈ keys (p1 * q1)› have "u ∈ keys (p1 * q1 + (p1 * q2 + p2 * q))" by (rule in_keys_plusI1)
thus "u ∈ keys (p * q)" by (simp only: p q algebra_simps)
qed
finally show "poly_deg p + poly_deg q ≤ poly_deg (p * q)" .
qed
corollary poly_deg_monom_mult_le:
"poly_deg (punit.monom_mult c (t::_ ⇒⇩0 'a::add_linorder_min) p) ≤ deg_pm t + poly_deg p"
proof -
have "poly_deg (punit.monom_mult c t p) ≤ poly_deg (monomial c t) + poly_deg p"
by (simp only: times_monomial_left[symmetric] poly_deg_times_le)
also have "... ≤ deg_pm t + poly_deg p" by (simp add: poly_deg_monomial)
finally show ?thesis .
qed
lemma poly_deg_monom_mult:
assumes "c ≠ 0" and "p ≠ (0::(_ ⇒⇩0 'a::add_linorder_min) ⇒⇩0 'b::semiring_no_zero_divisors)"
shows "poly_deg (punit.monom_mult c t p) = deg_pm t + poly_deg p"
proof (rule order.antisym, fact poly_deg_monom_mult_le)
from assms(2) obtain s where "s ∈ keys p" and "poly_deg p = deg_pm s" by (rule poly_degE)
have "deg_pm t + poly_deg p = deg_pm (t + s)" by (simp add: ‹poly_deg p = deg_pm s› deg_pm_plus)
also have "... ≤ poly_deg (punit.monom_mult c t p)"
proof (rule poly_deg_max_keys)
from ‹s ∈ keys p› show "t + s ∈ keys (punit.monom_mult c t p)"
unfolding punit.keys_monom_mult[OF assms(1)] by fastforce
qed
finally show "deg_pm t + poly_deg p ≤ poly_deg (punit.monom_mult c t p)" .
qed
lemma poly_deg_map_scale:
"poly_deg (c ⋅ p) = (if c = (0::_::semiring_no_zero_divisors) then 0 else poly_deg p)"
by (simp add: poly_deg_def keys_map_scale)
lemma poly_deg_sum_le: "((poly_deg (sum f A))::'a::add_linorder_min) ≤ Max (poly_deg ` f ` A)"
proof (cases "finite A")
case True
thus ?thesis
proof (induct A)
case empty
show ?case by simp
next
case (insert a A)
show ?case
proof (cases "A = {}")
case True
thus ?thesis by simp
next
case False
have "poly_deg (sum f (insert a A)) ≤ max (poly_deg (f a)) (poly_deg (sum f A))"
by (simp only: comm_monoid_add_class.sum.insert[OF insert(1) insert(2)] poly_deg_plus_le)
also have "... ≤ max (poly_deg (f a)) (Max (poly_deg ` f ` A))"
using insert(3) max.mono by blast
also have "... = (Max (poly_deg ` f ` (insert a A)))" using False by (simp add: insert(1))
finally show ?thesis .
qed
qed
next
case False
thus ?thesis by simp
qed
lemma poly_deg_prod_le: "((poly_deg (prod f A))::'a::add_linorder_min) ≤ (∑a∈A. poly_deg (f a))"
proof (cases "finite A")
case True
thus ?thesis
proof (induct A)
case empty
show ?case by simp
next
case (insert a A)
have "poly_deg (prod f (insert a A)) ≤ (poly_deg (f a)) + (poly_deg (prod f A))"
by (simp only: comm_monoid_mult_class.prod.insert[OF insert(1) insert(2)] poly_deg_times_le)
also have "... ≤ (poly_deg (f a)) + (∑a∈A. poly_deg (f a))"
using insert(3) add_le_cancel_left by blast
also have "... = (∑a∈insert a A. poly_deg (f a))" by (simp add: insert(1) insert(2))
finally show ?case .
qed
next
case False
thus ?thesis by simp
qed
lemma maxdeg_max:
assumes "finite A" and "p ∈ A"
shows "poly_deg p ≤ maxdeg A"
unfolding maxdeg_def using assms by auto
lemma mindeg_min:
assumes "finite A" and "p ∈ A"
shows "mindeg A ≤ poly_deg p"
unfolding mindeg_def using assms by auto
subsection ‹Indeterminates›
definition indets :: "(('x ⇒⇩0 nat) ⇒⇩0 'b::zero) ⇒ 'x set"
where "indets p = ⋃ (keys ` keys p)"
definition PPs :: "'x set ⇒ ('x ⇒⇩0 nat) set" (".[(_)]")
where "PPs X = {t. keys t ⊆ X}"
definition Polys :: "'x set ⇒ (('x ⇒⇩0 nat) ⇒⇩0 'b::zero) set" ("P[(_)]")
where "Polys X = {p. keys p ⊆ .[X]}"
subsubsection ‹@{const indets}›
lemma in_indetsI:
assumes "x ∈ keys t" and "t ∈ keys p"
shows "x ∈ indets p"
using assms by (auto simp add: indets_def)
lemma in_indetsE:
assumes "x ∈ indets p"
obtains t where "t ∈ keys p" and "x ∈ keys t"
using assms by (auto simp add: indets_def)
lemma keys_subset_indets: "t ∈ keys p ⟹ keys t ⊆ indets p"
by (auto dest: in_indetsI)
lemma indets_empty_imp_monomial:
assumes "indets p = {}"
shows "monomial (lookup p 0) 0 = p"
proof (rule keys_subset_singleton_imp_monomial, rule)
fix t
assume "t ∈ keys p"
have "t = 0"
proof (rule ccontr)
assume "t ≠ 0"
hence "keys t ≠ {}" by simp
then obtain x where "x ∈ keys t" by blast
from this ‹t ∈ keys p› have "x ∈ indets p" by (rule in_indetsI)
with assms show False by simp
qed
thus "t ∈ {0}" by simp
qed
lemma finite_indets: "finite (indets p)"
by (simp only: indets_def, rule finite_UN_I, (rule finite_keys)+)
lemma indets_zero [simp]: "indets 0 = {}"
by (simp add: indets_def)
lemma indets_one [simp]: "indets 1 = {}"
by (simp add: indets_def)
lemma indets_monomial_single_subset: "indets (monomial c (Poly_Mapping.single v k)) ⊆ {v}"
proof
fix x assume "x ∈ indets (monomial c (Poly_Mapping.single v k))"
then have "x = v" unfolding indets_def
by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq)
thus "x ∈ {v}" by simp
qed
lemma indets_monomial_single:
assumes "c ≠ 0" and "k ≠ 0"
shows "indets (monomial c (Poly_Mapping.single v k)) = {v}"
proof (rule, fact indets_monomial_single_subset, simp)
from assms show "v ∈ indets (monomial c (monomial k v))" by (simp add: indets_def)
qed
lemma indets_monomial:
assumes "c ≠ 0"
shows "indets (monomial c t) = keys t"
proof (rule antisym; rule subsetI)
fix x
assume "x ∈ indets (monomial c t)"
then have "lookup t x ≠ 0" unfolding indets_def
by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq)
thus "x ∈ keys t" by (meson lookup_not_eq_zero_eq_in_keys)
next
fix x
assume "x ∈ keys t"
then have "lookup t x ≠ 0" by (meson lookup_not_eq_zero_eq_in_keys)
thus "x ∈ indets (monomial c t)" unfolding indets_def using assms
by (metis UN_iff lookup_not_eq_zero_eq_in_keys lookup_single_eq)
qed
lemma indets_monomial_subset: "indets (monomial c t) ⊆ keys t"
by (cases "c = 0", simp_all add: indets_def)
lemma indets_monomial_zero [simp]: "indets (monomial c 0) = {}"
by (simp add: indets_def)
lemma indets_plus_subset: "indets (p + q) ⊆ indets p ∪ indets q"
proof
fix x
assume "x ∈ indets (p + q)"
then obtain t where "x ∈ keys t" and "t ∈ keys (p + q)" by (metis UN_E indets_def)
hence "t ∈ keys p ∪ keys q" by (metis Poly_Mapping.keys_add subsetCE)
thus "x ∈ indets p ∪ indets q" using indets_def ‹x ∈ keys t› by fastforce
qed
lemma indets_uminus [simp]: "indets (-p) = indets p"
by (simp add: indets_def keys_uminus)
lemma indets_minus_subset: "indets (p - q) ⊆ indets p ∪ indets q"
proof
fix x
assume "x ∈ indets (p - q)"
then obtain t where "x ∈ keys t" and "t ∈ keys (p - q)" by (metis UN_E indets_def)
hence "t ∈ keys p ∪ keys q" by (metis keys_minus subsetCE)
thus "x ∈ indets p ∪ indets q" using indets_def ‹x ∈ keys t› by fastforce
qed
lemma indets_times_subset: "indets (p * q) ⊆ indets p ∪ indets (q::(_ ⇒⇩0 _::cancel_comm_monoid_add) ⇒⇩0 _)"
proof
fix x
assume "x ∈ indets (p * q)"
then obtain t where "t ∈ keys (p * q)" and "x ∈ keys t" unfolding indets_def by blast
from this(1) obtain u v where "u ∈ keys p" "v ∈ keys q" and "t = u + v" by (rule in_keys_timesE)
hence "x ∈ keys u ∪ keys v" by (metis ‹x ∈ keys t› Poly_Mapping.keys_add subsetCE)
thus "x ∈ indets p ∪ indets q" unfolding indets_def using ‹u ∈ keys p› ‹v ∈ keys q› by blast
qed
corollary indets_monom_mult_subset: "indets (punit.monom_mult c t p) ⊆ keys t ∪ indets p"
proof -
have "indets (punit.monom_mult c t p) ⊆ indets (monomial c t) ∪ indets p"
by (simp only: times_monomial_left[symmetric] indets_times_subset)
also have "... ⊆ keys t ∪ indets p" using indets_monomial_subset[of t c] by blast
finally show ?thesis .
qed
lemma indets_monom_mult:
assumes "c ≠ 0" and "p ≠ (0::('x ⇒⇩0 nat) ⇒⇩0 'b::semiring_no_zero_divisors)"
shows "indets (punit.monom_mult c t p) = keys t ∪ indets p"
proof (rule, fact indets_monom_mult_subset, rule)
fix x
assume "x ∈ keys t ∪ indets p"
thus "x ∈ indets (punit.monom_mult c t p)"
proof
assume "x ∈ keys t"
from assms(2) have "keys p ≠ {}" by simp
then obtain s where "s ∈ keys p" by blast
hence "t + s ∈ (+) t ` keys p" by fastforce
also from assms(1) have "... = keys (punit.monom_mult c t p)" by (simp add: punit.keys_monom_mult)
finally have "t + s ∈ keys (punit.monom_mult c t p)" .
show ?thesis
proof (rule in_indetsI)
from ‹x ∈ keys t› show "x ∈ keys (t + s)" by (simp add: keys_plus_ninv_comm_monoid_add)
qed fact
next
assume "x ∈ indets p"
then obtain s where "s ∈ keys p" and "x ∈ keys s" by (rule in_indetsE)
from this(1) have "t + s ∈ (+) t ` keys p" by fastforce
also from assms(1) have "... = keys (punit.monom_mult c t p)" by (simp add: punit.keys_monom_mult)
finally have "t + s ∈ keys (punit.monom_mult c t p)" .
show ?thesis
proof (rule in_indetsI)
from ‹x ∈ keys s› show "x ∈ keys (t + s)" by (simp add: keys_plus_ninv_comm_monoid_add)
qed fact
qed
qed
lemma indets_sum_subset: "indets (sum f A) ⊆ (⋃a∈A. indets (f a))"
proof (cases "finite A")
case True
thus ?thesis
proof (induct A)
case empty
show ?case by simp
next
case (insert a A)
have "indets (sum f (insert a A)) ⊆ indets (f a) ∪ indets (sum f A)"
by (simp only: comm_monoid_add_class.sum.insert[OF insert(1) insert(2)] indets_plus_subset)
also have "... ⊆ indets (f a) ∪ (⋃a∈A. indets (f a))" using insert(3) by blast
also have "... = (⋃a∈insert a A. indets (f a))" by simp
finally show ?case .
qed
next
case False
thus ?thesis by simp
qed
lemma indets_prod_subset:
"indets (prod (f::_ ⇒ ((_ ⇒⇩0 _::cancel_comm_monoid_add) ⇒⇩0 _)) A) ⊆ (⋃a∈A. indets (f a))"
proof (cases "finite A")
case True
thus ?thesis
proof (induct A)
case empty
show ?case by simp
next
case (insert a A)
have "indets (prod f (insert a A)) ⊆ indets (f a) ∪ indets (prod f A)"
by (simp only: comm_monoid_mult_class.prod.insert[OF insert(1) insert(2)] indets_times_subset)
also have "... ⊆ indets (f a) ∪ (⋃a∈A. indets (f a))" using insert(3) by blast
also have "... = (⋃a∈insert a A. indets (f a))" by simp
finally show ?case .
qed
next
case False
thus ?thesis by simp
qed
lemma indets_power_subset: "indets (p ^ n) ⊆ indets (p::('x ⇒⇩0 nat) ⇒⇩0 'b::comm_semiring_1)"
proof -
have "p ^ n = (∏i=0..<n. p)" by simp
also have "indets ... ⊆ (⋃i∈{0..<n}. indets p)" by (fact indets_prod_subset)
also have "... ⊆ indets p" by simp
finally show ?thesis .
qed
lemma indets_empty_iff_poly_deg_zero: "indets p = {} ⟷ poly_deg p = 0"
proof
assume "indets p = {}"
hence "monomial (lookup p 0) 0 = p" by (rule indets_empty_imp_monomial)
moreover have "poly_deg (monomial (lookup p 0) 0) = 0" by simp
ultimately show "poly_deg p = 0" by metis
next
assume "poly_deg p = 0"
hence "monomial (lookup p 0) 0 = p" by (rule poly_deg_zero_imp_monomial)
moreover have "indets (monomial (lookup p 0) 0) = {}" by simp
ultimately show "indets p = {}" by metis
qed
subsubsection ‹@{const PPs}›
lemma PPsI: "keys t ⊆ X ⟹ t ∈ .[X]"
by (simp add: PPs_def)
lemma PPsD: "t ∈ .[X] ⟹ keys t ⊆ X"
by (simp add: PPs_def)
lemma PPs_empty [simp]: ".[{}] = {0}"
by (simp add: PPs_def)
lemma PPs_UNIV [simp]: ".[UNIV] = UNIV"
by (simp add: PPs_def)
lemma PPs_singleton: ".[{x}] = range (Poly_Mapping.single x)"
proof (rule set_eqI)
fix t
show "t ∈ .[{x}] ⟷ t ∈ range (Poly_Mapping.single x)"
proof
assume "t ∈ .[{x}]"
hence "keys t ⊆ {x}" by (rule PPsD)
hence "Poly_Mapping.single x (lookup t x) = t" by (rule keys_subset_singleton_imp_monomial)
from this[symmetric] UNIV_I show "t ∈ range (Poly_Mapping.single x)" ..
next
assume "t ∈ range (Poly_Mapping.single x)"
then obtain e where "t = Poly_Mapping.single x e" ..
thus "t ∈ .[{x}]" by (simp add: PPs_def)
qed
qed
lemma zero_in_PPs: "0 ∈ .[X]"
by (simp add: PPs_def)
lemma PPs_mono: "X ⊆ Y ⟹ .[X] ⊆ .[Y]"
by (auto simp: PPs_def)
lemma PPs_closed_single:
assumes "x ∈ X"
shows "Poly_Mapping.single x e ∈ .[X]"
proof (rule PPsI)
have "keys (Poly_Mapping.single x e) ⊆ {x}" by simp
also from assms have "... ⊆ X" by simp
finally show "keys (Poly_Mapping.single x e) ⊆ X" .
qed
lemma PPs_closed_plus:
assumes "s ∈ .[X]" and "t ∈ .[X]"
shows "s + t ∈ .[X]"
proof -
have "keys (s + t) ⊆ keys s ∪ keys t" by (fact Poly_Mapping.keys_add)
also from assms have "... ⊆ X" by (simp add: PPs_def)
finally show ?thesis by (rule PPsI)
qed
lemma PPs_closed_minus:
assumes "s ∈ .[X]"
shows "s - t ∈ .[X]"
proof -
have "keys (s - t) ⊆ keys s" by (metis lookup_minus lookup_not_eq_zero_eq_in_keys subsetI zero_diff)
also from assms have "... ⊆ X" by (rule PPsD)
finally show ?thesis by (rule PPsI)
qed
lemma PPs_closed_adds:
assumes "s ∈ .[X]" and "t adds s"
shows "t ∈ .[X]"
proof -
from assms(2) have "s - (s - t) = t" by (metis add_minus_2 adds_minus)
moreover from assms(1) have "s - (s - t) ∈ .[X]" by (rule PPs_closed_minus)
ultimately show ?thesis by simp
qed
lemma PPs_closed_gcs:
assumes "s ∈ .[X]"
shows "gcs s t ∈ .[X]"
using assms gcs_adds by (rule PPs_closed_adds)
lemma PPs_closed_lcs:
assumes "s ∈ .[X]" and "t ∈ .[X]"
shows "lcs s t ∈ .[X]"
proof -
from assms have "s + t ∈ .[X]" by (rule PPs_closed_plus)
hence "(s + t) - gcs s t ∈ .[X]" by (rule PPs_closed_minus)
thus ?thesis by (simp add: gcs_plus_lcs[of s t, symmetric])
qed
lemma PPs_closed_except': "t ∈ .[X] ⟹ except t Y ∈ .[X - Y]"
by (auto simp: keys_except PPs_def)
lemma PPs_closed_except: "t ∈ .[X] ⟹ except t Y ∈ .[X]"
by (auto simp: keys_except PPs_def)
lemma PPs_UnI:
assumes "tx ∈ .[X]" and "ty ∈ .[Y]" and "t = tx + ty"
shows "t ∈ .[X ∪ Y]"
proof -
from assms(1) have "tx ∈ .[X ∪ Y]" by rule (simp add: PPs_mono)
moreover from assms(2) have "ty ∈ .[X ∪ Y]" by rule (simp add: PPs_mono)
ultimately show ?thesis unfolding assms(3) by (rule PPs_closed_plus)
qed
lemma PPs_UnE:
assumes "t ∈ .[X ∪ Y]"
obtains tx ty where "tx ∈ .[X]" and "ty ∈ .[Y]" and "t = tx + ty"
proof -
from assms have "keys t ⊆ X ∪ Y" by (rule PPsD)
define tx where "tx = except t (- X)"
have "keys tx ⊆ X" by (simp add: tx_def keys_except)
hence "tx ∈ .[X]" by (simp add: PPs_def)
have "tx adds t" by (simp add: tx_def adds_poly_mappingI le_fun_def lookup_except)
from adds_minus[OF this] have "t = tx + (t - tx)" by (simp only: ac_simps)
have "t - tx ∈ .[Y]"
proof (rule PPsI, rule)
fix x
assume "x ∈ keys (t - tx)"
also have "... ⊆ keys t ∪ keys tx" by (rule keys_minus)
also from ‹keys t ⊆ X ∪ Y› ‹keys tx ⊆ X› have "... ⊆ X ∪ Y" by blast
finally show "x ∈ Y"
proof
assume "x ∈ X"
hence "x ∉ keys (t - tx)" by (simp add: tx_def lookup_except lookup_minus in_keys_iff)
thus ?thesis using ‹x ∈ keys (t - tx)› ..
qed
qed
with ‹tx ∈ .[X]› show ?thesis using ‹t = tx + (t - tx)› ..
qed
lemma PPs_Un: ".[X ∪ Y] = (⋃t∈.[X]. (+) t ` .[Y])" (is "?A = ?B")
proof (rule set_eqI)
fix t
show "t ∈ ?A ⟷ t ∈ ?B"
proof
assume "t ∈ ?A"
then obtain tx ty where "tx ∈ .[X]" and "ty ∈ .[Y]" and "t = tx + ty" by (rule PPs_UnE)
from this(2) have "t ∈ (+) tx ` .[Y]" unfolding ‹t = tx + ty› by (rule imageI)
with ‹tx ∈ .[X]› show "t ∈ ?B" ..
next
assume "t ∈ ?B"
then obtain tx where "tx ∈ .[X]" and "t ∈ (+) tx ` .[Y]" ..
from this(2) obtain ty where "ty ∈ .[Y]" and "t = tx + ty" ..
with ‹tx ∈ .[X]› show "t ∈ ?A" by (rule PPs_UnI)
qed
qed
corollary PPs_insert: ".[insert x X] = (⋃e. (+) (Poly_Mapping.single x e) ` .[X])"
proof -
have ".[insert x X] = .[{x} ∪ X]" by simp
also have "... = (⋃t∈.[{x}]. (+) t ` .[X])" by (fact PPs_Un)
also have "... = (⋃e. (+) (Poly_Mapping.single x e) ` .[X])" by (simp add: PPs_singleton)
finally show ?thesis .
qed
corollary PPs_insertI:
assumes "tx ∈ .[X]" and "t = Poly_Mapping.single x e + tx"
shows "t ∈ .[insert x X]"
proof -
from assms(1) have "t ∈ (+) (Poly_Mapping.single x e) ` .[X]" unfolding assms(2) by (rule imageI)
with UNIV_I show ?thesis unfolding PPs_insert by (rule UN_I)
qed
corollary PPs_insertE:
assumes "t ∈ .[insert x X]"
obtains e tx where "tx ∈ .[X]" and "t = Poly_Mapping.single x e + tx"
proof -
from assms obtain e where "t ∈ (+) (Poly_Mapping.single x e) ` .[X]" unfolding PPs_insert ..
then obtain tx where "tx ∈ .[X]" and "t = Poly_Mapping.single x e + tx" ..
thus ?thesis ..
qed
lemma PPs_Int: ".[X ∩ Y] = .[X] ∩ .[Y]"
by (auto simp: PPs_def)
lemma PPs_INT: ".[⋂ X] = ⋂ (PPs ` X)"
by (auto simp: PPs_def)
subsubsection ‹@{const Polys}›
lemma Polys_alt: "P[X] = {p. indets p ⊆ X}"
by (auto simp: Polys_def PPs_def indets_def)
lemma PolysI: "keys p ⊆ .[X] ⟹ p ∈ P[X]"
by (simp add: Polys_def)
lemma PolysI_alt: "indets p ⊆ X ⟹ p ∈ P[X]"
by (simp add: Polys_alt)
lemma PolysD:
assumes "p ∈ P[X]"
shows "keys p ⊆ .[X]" and "indets p ⊆ X"
using assms by (simp add: Polys_def, simp add: Polys_alt)
lemma Polys_empty: "P[{}] = ((range (Poly_Mapping.single 0))::(('x ⇒⇩0 nat) ⇒⇩0 'b::zero) set)"
proof (rule set_eqI)
fix p :: "('x ⇒⇩0 nat) ⇒⇩0 'b::zero"
show "p ∈ P[{}] ⟷ p ∈ range (Poly_Mapping.single 0)"
proof
assume "p ∈ P[{}]"
hence "keys p ⊆ .[{}]" by (rule PolysD)
also have "... = {0}" by simp
finally have "keys p ⊆ {0}" .
hence "Poly_Mapping.single 0 (lookup p 0) = p" by (rule keys_subset_singleton_imp_monomial)
from this[symmetric] UNIV_I show "p ∈ range (Poly_Mapping.single 0)" ..
next
assume "p ∈ range (Poly_Mapping.single 0)"
then obtain c where "p = monomial c 0" ..
thus "p ∈ P[{}]" by (simp add: Polys_def)
qed
qed
lemma Polys_UNIV [simp]: "P[UNIV] = UNIV"
by (simp add: Polys_def)
lemma zero_in_Polys: "0 ∈ P[X]"
by (simp add: Polys_def)
lemma one_in_Polys: "1 ∈ P[X]"
by (simp add: Polys_def zero_in_PPs)
lemma Polys_mono: "X ⊆ Y ⟹ P[X] ⊆ P[Y]"
by (auto simp: Polys_alt)
lemma Polys_closed_monomial: "t ∈ .[X] ⟹ monomial c t ∈ P[X]"
using indets_monomial_subset[where c=c and t=t] by (auto simp: Polys_alt PPs_def)
lemma Polys_closed_plus: "p ∈ P[X] ⟹ q ∈ P[X] ⟹ p + q ∈ P[X]"
using indets_plus_subset[of p q] by (auto simp: Polys_alt PPs_def)
lemma Polys_closed_uminus: "p ∈ P[X] ⟹ -p ∈ P[X]"
by (simp add: Polys_def keys_uminus)
lemma Polys_closed_minus: "p ∈ P[X] ⟹ q ∈ P[X] ⟹ p - q ∈ P[X]"
using indets_minus_subset[of p q] by (auto simp: Polys_alt PPs_def)
lemma Polys_closed_monom_mult: "t ∈ .[X] ⟹ p ∈ P[X] ⟹ punit.monom_mult c t p ∈ P[X]"
using indets_monom_mult_subset[of c t p] by (auto simp: Polys_alt PPs_def)
corollary Polys_closed_map_scale: "p ∈ P[X] ⟹ (c::_::semiring_0) ⋅ p ∈ P[X]"
unfolding punit.map_scale_eq_monom_mult using zero_in_PPs by (rule Polys_closed_monom_mult)
lemma Polys_closed_times: "p ∈ P[X] ⟹ q ∈ P[X] ⟹ p * q ∈ P[X]"
using indets_times_subset[of p q] by (auto simp: Polys_alt PPs_def)
lemma Polys_closed_power: "p ∈ P[X] ⟹ p ^ m ∈ P[X]"
by (induct m) (auto intro: one_in_Polys Polys_closed_times)
lemma Polys_closed_sum: "(⋀a. a ∈ A ⟹ f a ∈ P[X]) ⟹ sum f A ∈ P[X]"
by (induct A rule: infinite_finite_induct) (auto intro: zero_in_Polys Polys_closed_plus)
lemma Polys_closed_prod: "(⋀a. a ∈ A ⟹ f a ∈ P[X]) ⟹ prod f A ∈ P[X]"
by (induct A rule: infinite_finite_induct) (auto intro: one_in_Polys Polys_closed_times)
lemma Polys_closed_sum_list: "(⋀x. x ∈ set xs ⟹ x ∈ P[X]) ⟹ sum_list xs ∈ P[X]"
by (induct xs) (auto intro: zero_in_Polys Polys_closed_plus)
lemma Polys_closed_except: "p ∈ P[X] ⟹ except p T ∈ P[X]"
by (auto intro!: PolysI simp: keys_except dest!: PolysD(1))
lemma times_in_PolysD:
assumes "p * q ∈ P[X]" and "p ∈ P[X]" and "p ≠ (0::('x::linorder ⇒⇩0 nat) ⇒⇩0 'a::semiring_no_zero_divisors)"
shows "q ∈ P[X]"
proof -
define qX where "qX = except q (- .[X])"
define qY where "qY = except q .[X]"
have q: "q = qX + qY" by (simp only: qX_def qY_def add.commute flip: except_decomp)
have "qX ∈ P[X]" by (rule PolysI) (simp add: qX_def keys_except)
with assms(2) have "p * qX ∈ P[X]" by (rule Polys_closed_times)
show ?thesis
proof (cases "qY = 0")
case True
with ‹qX ∈ P[X]› show ?thesis by (simp add: q)
next
case False
with assms(3) have "p * qY ≠ 0" by simp
hence "keys (p * qY) ≠ {}" by simp
then obtain t where "t ∈ keys (p * qY)" by blast
then obtain t1 t2 where "t2 ∈ keys qY" and t: "t = t1 + t2" by (rule in_keys_timesE)
have "t ∉ .[X]" unfolding t
proof
assume "t1 + t2 ∈ .[X]"
hence "t1 + t2 - t1 ∈ .[X]" by (rule PPs_closed_minus)
hence "t2 ∈ .[X]" by simp
with ‹t2 ∈ keys qY› show False by (simp add: qY_def keys_except)
qed
have "t ∉ keys (p * qX)"
proof
assume "t ∈ keys (p * qX)"
also from ‹p * qX ∈ P[X]› have "… ⊆ .[X]" by (rule PolysD)
finally have "t ∈ .[X]" .
with ‹t ∉ .[X]› show False ..
qed
with ‹t ∈ keys (p * qY)› have "t ∈ keys (p * qX + p * qY)" by (rule in_keys_plusI2)
also have "… = keys (p * q)" by (simp only: q algebra_simps)
finally have "p * q ∉ P[X]" using ‹t ∉ .[X]› by (auto simp: Polys_def)
thus ?thesis using assms(1) ..
qed
qed
lemma poly_mapping_plus_induct_Polys [consumes 1, case_names 0 plus]:
assumes "p ∈ P[X]" and "P 0"
and "⋀p c t. t ∈ .[X] ⟹ p ∈ P[X] ⟹ c ≠ 0 ⟹ t ∉ keys p ⟹ P p ⟹ P (monomial c t + p)"
shows "P p"
using assms(1)
proof (induct p rule: poly_mapping_plus_induct)
case 1
show ?case by (fact assms(2))
next
case step: (2 p c t)
from step.hyps(1) have 1: "keys (monomial c t) = {t}" by simp
also from step.hyps(2) have "… ∩ keys p = {}" by simp
finally have "keys (monomial c t + p) = keys (monomial c t) ∪ keys p" by (rule keys_add[symmetric])
hence "keys (monomial c t + p) = insert t (keys p)" by (simp only: 1 flip: insert_is_Un)
moreover from step.prems(1) have "keys (monomial c t + p) ⊆ .[X]" by (rule PolysD)
ultimately have "t ∈ .[X]" and "keys p ⊆ .[X]" by blast+
from this(2) have "p ∈ P[X]" by (rule PolysI)
hence "P p" by (rule step.hyps)
with ‹t ∈ .[X]› ‹p ∈ P[X]› step.hyps(1, 2) show ?case by (rule assms(3))
qed
lemma Polys_Int: "P[X ∩ Y] = P[X] ∩ P[Y]"
by (auto simp: Polys_def PPs_Int)
lemma Polys_INT: "P[⋂ X] = ⋂ (Polys ` X)"
by (auto simp: Polys_def PPs_INT)
subsection ‹Substitution Homomorphism›
text ‹The substitution homomorphism defined here is more general than @{const insertion}, since
it replaces indeterminates by @{emph ‹polynomials›} rather than coefficients, and therefore
constructs new polynomials.›
definition subst_pp :: "('x ⇒ (('y ⇒⇩0 nat) ⇒⇩0 'a)) ⇒ ('x ⇒⇩0 nat) ⇒ (('y ⇒⇩0 nat) ⇒⇩0 'a::comm_semiring_1)"
where "subst_pp f t = (∏x∈keys t. (f x) ^ (lookup t x))"
definition poly_subst :: "('x ⇒ (('y ⇒⇩0 nat) ⇒⇩0 'a)) ⇒ (('x ⇒⇩0 nat) ⇒⇩0 'a) ⇒ (('y ⇒⇩0 nat) ⇒⇩0 'a::comm_semiring_1)"
where "poly_subst f p = (∑t∈keys p. punit.monom_mult (lookup p t) 0 (subst_pp f t))"
lemma subst_pp_alt: "subst_pp f t = (∏x. (f x) ^ (lookup t x))"
proof -
from finite_keys have "subst_pp f t = (∏x. if x ∈ keys t then (f x) ^ (lookup t x) else 1)"
unfolding subst_pp_def by (rule Prod_any.conditionalize)
also have "... = (∏x. (f x) ^ (lookup t x))" by (rule Prod_any.cong) (simp add: in_keys_iff)
finally show ?thesis .
qed
lemma subst_pp_zero [simp]: "subst_pp f 0 = 1"
by (simp add: subst_pp_def)
lemma subst_pp_trivial_not_zero:
assumes "t ≠ 0"
shows "subst_pp (λ_. 0) t = (0::(_ ⇒⇩0 'b::comm_semiring_1))"
unfolding subst_pp_def using finite_keys
proof (rule prod_zero)
from assms have "keys t ≠ {}" by simp
then obtain x where "x ∈ keys t" by blast
thus "∃x∈keys t. 0 ^ lookup t x = (0::(_ ⇒⇩0 'b))"
proof
from ‹x ∈ keys t› have "0 < lookup t x" by (simp add: in_keys_iff)
thus "0 ^ lookup t x = (0::(_ ⇒⇩0 'b))" by (rule Power.semiring_1_class.zero_power)
qed
qed
lemma subst_pp_single: "subst_pp f (Poly_Mapping.single x e) = (f x) ^ e"
by (simp add: subst_pp_def)
corollary subst_pp_trivial: "subst_pp (λ_. 0) t = (if t = 0 then 1 else 0)"
by (simp split: if_split add: subst_pp_trivial_not_zero)
lemma power_lookup_not_one_subset_keys: "{x. f x ^ (lookup t x) ≠ 1} ⊆ keys t"
proof (rule, simp)
fix x
assume "f x ^ (lookup t x) ≠ 1"
thus "x ∈ keys t" unfolding in_keys_iff by (metis power_0)
qed
corollary finite_power_lookup_not_one: "finite {x. f x ^ (lookup t x) ≠ 1}"
by (rule finite_subset, fact power_lookup_not_one_subset_keys, fact finite_keys)
lemma subst_pp_plus: "subst_pp f (s + t) = subst_pp f s * subst_pp f t"
by (simp add: subst_pp_alt lookup_add power_add, rule Prod_any.distrib, (fact finite_power_lookup_not_one)+)
lemma subst_pp_id:
assumes "⋀x. x ∈ keys t ⟹ f x = monomial 1 (Poly_Mapping.single x 1)"
shows "subst_pp f t = monomial 1 t"
proof -
have "subst_pp f t = (∏x∈keys t. monomial 1 (Poly_Mapping.single x (lookup t x)))"
proof (simp only: subst_pp_def, rule prod.cong, fact refl)
fix x
assume "x ∈ keys t"
thus "f x ^ lookup t x = monomial 1 (Poly_Mapping.single x (lookup t x))"
by (simp add: assms monomial_single_power)
qed
also have "... = monomial 1 t"
by (simp add: punit.monomial_prod_sum[symmetric] poly_mapping_sum_monomials)
finally show ?thesis .
qed
lemma in_indets_subst_ppE:
assumes "x ∈ indets (subst_pp f t)"
obtains y where "y ∈ keys t" and "x ∈ indets (f y)"
proof -
note assms
also have "indets (subst_pp f t) ⊆ (⋃y∈keys t. indets ((f y) ^ (lookup t y)))" unfolding subst_pp_def
by (rule indets_prod_subset)
finally obtain y where "y ∈ keys t" and "x ∈ indets ((f y) ^ (lookup t y))" ..
note this(2)
also have "indets ((f y) ^ (lookup t y)) ⊆ indets (f y)" by (rule indets_power_subset)
finally have "x ∈ indets (f y)" .
with ‹y ∈ keys t› show ?thesis ..
qed
lemma subst_pp_by_monomials:
assumes "⋀y. y ∈ keys t ⟹ f y = monomial (c y) (s y)"
shows "subst_pp f t = monomial (∏y∈keys t. (c y) ^ lookup t y) (∑y∈keys t. lookup t y ⋅ s y)"
by (simp add: subst_pp_def assms monomial_power_map_scale punit.monomial_prod_sum)
lemma poly_deg_subst_pp_eq_zeroI:
assumes "⋀x. x ∈ keys t ⟹ poly_deg (f x) = 0"
shows "poly_deg (subst_pp f t) = 0"
proof -
have "poly_deg (subst_pp f t) ≤ (∑x∈keys t. poly_deg ((f x) ^ (lookup t x)))"
unfolding subst_pp_def by (fact poly_deg_prod_le)
also have "... = 0"
proof (rule sum.neutral, rule)
fix x
assume "x ∈ keys t"
hence "poly_deg (f x) = 0" by (rule assms)
have "f x ^ lookup t x = (∏i=0..<lookup t x. f x)" by simp
also have "poly_deg ... ≤ (∑i=0..<lookup t x. poly_deg (f x))" by (rule poly_deg_prod_le)
also have "... = 0" by (simp add: ‹poly_deg (f x) = 0›)
finally show "poly_deg (f x ^ lookup t x) = 0" by simp
qed
finally show ?thesis by simp
qed
lemma poly_deg_subst_pp_le:
assumes "⋀x. x ∈ keys t ⟹ poly_deg (f x) ≤ 1"
shows "poly_deg (subst_pp f t) ≤ deg_pm t"
proof -
have "poly_deg (subst_pp f t) ≤ (∑x∈keys t. poly_deg ((f x) ^ (lookup t x)))"
unfolding subst_pp_def by (fact poly_deg_prod_le)
also have "... ≤ (∑x∈keys t. lookup t x)"
proof (rule sum_mono)
fix x
assume "x ∈ keys t"
hence "poly_deg (f x) ≤ 1" by (rule assms)
have "f x ^ lookup t x = (∏i=0..<lookup t x. f x)" by simp
also have "poly_deg ... ≤ (∑i=0..<lookup t x. poly_deg (f x))" by (rule poly_deg_prod_le)
also from ‹poly_deg (f x) ≤ 1› have "... ≤ (∑i=0..<lookup t x. 1)" by (rule sum_mono)
finally show "poly_deg (f x ^ lookup t x) ≤ lookup t x" by simp
qed
also have "... = deg_pm t" by (rule deg_pm_superset[symmetric], fact subset_refl, fact finite_keys)
finally show ?thesis by simp
qed
lemma poly_subst_alt: "poly_subst f p = (∑t. punit.monom_mult (lookup p t) 0 (subst_pp f t))"
proof -
from finite_keys have "poly_subst f p = (∑t. if t ∈ keys p then punit.monom_mult (lookup p t) 0 (subst_pp f t) else 0)"
unfolding poly_subst_def by (rule Sum_any.conditionalize)
also have "… = (∑t. punit.monom_mult (lookup p t) 0 (subst_pp f t))"
by (rule Sum_any.cong) (simp add: in_keys_iff)
finally show ?thesis .
qed
lemma poly_subst_trivial [simp]: "poly_subst (λ_. 0) p = monomial (lookup p 0) 0"
by (simp add: poly_subst_def subst_pp_trivial if_distrib in_keys_iff cong: if_cong)
(metis mult.right_neutral times_monomial_left)
lemma poly_subst_zero [simp]: "poly_subst f 0 = 0"
by (simp add: poly_subst_def)
lemma monom_mult_lookup_not_zero_subset_keys:
"{t. punit.monom_mult (lookup p t) 0 (subst_pp f t) ≠ 0} ⊆ keys p"
proof (rule, simp)
fix t
assume "punit.monom_mult (lookup p t) 0 (subst_pp f t) ≠ 0"
thus "t ∈ keys p" unfolding in_keys_iff by (metis punit.monom_mult_zero_left)
qed
corollary finite_monom_mult_lookup_not_zero:
"finite {t. punit.monom_mult (lookup p t) 0 (subst_pp f t) ≠ 0}"
by (rule finite_subset, fact monom_mult_lookup_not_zero_subset_keys, fact finite_keys)
lemma poly_subst_plus: "poly_subst f (p + q) = poly_subst f p + poly_subst f q"
by (simp add: poly_subst_alt lookup_add punit.monom_mult_dist_left, rule Sum_any.distrib,
(fact finite_monom_mult_lookup_not_zero)+)
lemma poly_subst_uminus: "poly_subst f (-p) = - poly_subst f (p::('x ⇒⇩0 nat) ⇒⇩0 'b::comm_ring_1)"
by (simp add: poly_subst_def keys_uminus punit.monom_mult_uminus_left sum_negf)
lemma poly_subst_minus:
"poly_subst f (p - q) = poly_subst f p - poly_subst f (q::('x ⇒⇩0 nat) ⇒⇩0 'b::comm_ring_1)"
proof -
have "poly_subst f (p + (-q)) = poly_subst f p + poly_subst f (-q)" by (fact poly_subst_plus)
thus ?thesis by (simp add: poly_subst_uminus)
qed
lemma poly_subst_monomial: "poly_subst f (monomial c t) = punit.monom_mult c 0 (subst_pp f t)"
by (simp add: poly_subst_def lookup_single)
corollary poly_subst_one [simp]: "poly_subst f 1 = 1"
by (simp add: single_one[symmetric] poly_subst_monomial punit.monom_mult_monomial del: single_one)
lemma poly_subst_times: "poly_subst f (p * q) = poly_subst f p * poly_subst f q"
proof -
have bij: "bij (λ(l, n, m). (m, l, n))"
by (auto intro!: bijI injI simp add: image_def)
let ?P = "keys p"
let ?Q = "keys q"
let ?PQ = "{s + t | s t. lookup p s ≠ 0 ∧ lookup q t ≠ 0}"
have fin_PQ: "finite ?PQ"
by (rule finite_not_eq_zero_sumI, simp_all)
have fin_1: "finite {l. lookup p l * (∑qa. lookup q qa when t = l + qa) ≠ 0}" for t
proof (rule finite_subset)
show "{l. lookup p l * (∑qa. lookup q qa when t = l + qa) ≠ 0} ⊆ keys p"
by (rule, auto simp: in_keys_iff)
qed (fact finite_keys)
have fin_2: "finite {v. (lookup q v when t = u + v) ≠ 0}" for t u
proof (rule finite_subset)
show "{v. (lookup q v when t = u + v) ≠ 0} ⊆ keys q"
by (rule, auto simp: in_keys_iff)
qed (fact finite_keys)
have fin_3: "finite {v. (lookup p u * lookup q v when t = u + v) ≠ 0}" for t u
proof (rule finite_subset)
show "{v. (lookup p u * lookup q v when t = u + v) ≠ 0} ⊆ keys q"
by (rule, auto simp add: in_keys_iff simp del: lookup_not_eq_zero_eq_in_keys)
qed (fact finite_keys)
have "(∑t. punit.monom_mult (lookup (p * q) t) 0 (subst_pp f t)) =
(∑t. ∑u. punit.monom_mult (lookup p u * (∑v. lookup q v when t = u + v)) 0 (subst_pp f t))"
by (simp add: times_poly_mapping.rep_eq prod_fun_def punit.monom_mult_Sum_any_left[OF fin_1])
also have "… = (∑t. ∑u. ∑v. (punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t)) when t = u + v)"
by (simp add: Sum_any_right_distrib[OF fin_2] punit.monom_mult_Sum_any_left[OF fin_3] mult_when punit.when_monom_mult)
also have "… = (∑t. (∑(u, v). (punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t)) when t = u + v))"
by (subst (2) Sum_any.cartesian_product [of "?P × ?Q"]) (auto simp: in_keys_iff)
also have "… = (∑(t, u, v). punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t) when t = u + v)"
apply (subst Sum_any.cartesian_product [of "?PQ × (?P × ?Q)"])
apply (auto simp: fin_PQ in_keys_iff)
apply (metis monomial_0I mult_not_zero times_monomial_left)
done
also have "… = (∑(u, v, t). punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t) when t = u + v)"
using bij by (rule Sum_any.reindex_cong [of "λ(u, v, t). (t, u, v)"]) (simp add: fun_eq_iff)
also have "… = (∑(u, v). ∑t. punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t) when t = u + v)"
apply (subst Sum_any.cartesian_product2 [of "(?P × ?Q) × ?PQ"])
apply (auto simp: fin_PQ in_keys_iff)
apply (metis monomial_0I mult_not_zero times_monomial_left)
done
also have "… = (∑(u, v). punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f u * subst_pp f v))"
by (simp add: subst_pp_plus)
also have "… = (∑u. ∑v. punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f u * subst_pp f v))"
by (subst Sum_any.cartesian_product [of "?P × ?Q"]) (auto simp: in_keys_iff)
also have "… = (∑u. ∑v. (punit.monom_mult (lookup p u) 0 (subst_pp f u)) * (punit.monom_mult (lookup q v) 0 (subst_pp f v)))"
by (simp add: times_monomial_left[symmetric] ac_simps mult_single)
also have "… = (∑t. punit.monom_mult (lookup p t) 0 (subst_pp f t)) *
(∑t. punit.monom_mult (lookup q t) 0 (subst_pp f t))"
by (rule Sum_any_product [symmetric], (fact finite_monom_mult_lookup_not_zero)+)
finally show ?thesis by (simp add: poly_subst_alt)
qed
corollary poly_subst_monom_mult:
"poly_subst f (punit.monom_mult c t p) = punit.monom_mult c 0 (subst_pp f t * poly_subst f p)"
by (simp only: times_monomial_left[symmetric] poly_subst_times poly_subst_monomial mult.assoc)
corollary poly_subst_monom_mult':
"poly_subst f (punit.monom_mult c t p) = (punit.monom_mult c 0 (subst_pp f t)) * poly_subst f p"
by (simp only: times_monomial_left[symmetric] poly_subst_times poly_subst_monomial)
lemma poly_subst_sum: "poly_subst f (sum p A) = (∑a∈A. poly_subst f (p a))"
by (rule fun_sum_commute, simp_all add: poly_subst_plus)
lemma poly_subst_prod: "poly_subst f (prod p A) = (∏a∈A. poly_subst f (p a))"
by (rule fun_prod_commute, simp_all add: poly_subst_times)
lemma poly_subst_power: "poly_subst f (p ^ n) = (poly_subst f p) ^ n"
by (induct n, simp_all add: poly_subst_times)
lemma poly_subst_subst_pp: "poly_subst f (subst_pp g t) = subst_pp (λx. poly_subst f (g x)) t"
by (simp only: subst_pp_def poly_subst_prod poly_subst_power)
lemma poly_subst_poly_subst: "poly_subst f (poly_subst g p) = poly_subst (λx. poly_subst f (g x)) p"
proof -
have "poly_subst f (poly_subst g p) =
poly_subst f (∑t∈keys p. punit.monom_mult (lookup p t) 0 (subst_pp g t))"
by (simp only: poly_subst_def)
also have "… = (∑t∈keys p. punit.monom_mult (lookup p t) 0 (subst_pp (λx. poly_subst f (g x)) t))"
by (simp add: poly_subst_sum poly_subst_monom_mult poly_subst_subst_pp)
also have "… = poly_subst (λx. poly_subst f (g x)) p" by (simp only: poly_subst_def)
finally show ?thesis .
qed
lemma poly_subst_id:
assumes "⋀x. x ∈ indets p ⟹ f x = monomial 1 (Poly_Mapping.single x 1)"
shows "poly_subst f p = p"
proof -
have "poly_subst f p = (∑t∈keys p. monomial (lookup p t) t)"
proof (simp only: poly_subst_def, rule sum.cong, fact refl)
fix t
assume "t ∈ keys p"
have eq: "subst_pp f t = monomial 1 t"
by (rule subst_pp_id, rule assms, erule in_indetsI, fact ‹t ∈ keys p›)
show "punit.monom_mult (lookup p t) 0 (subst_pp f t) = monomial (lookup p t) t"
by (simp add: eq punit.monom_mult_monomial)
qed
also have "... = p" by (simp only: poly_mapping_sum_monomials)
finally show ?thesis .
qed
lemma in_keys_poly_substE:
assumes "t ∈ keys (poly_subst f p)"
obtains s where "s ∈ keys p" and "t ∈ keys (subst_pp f s)"
proof -
note assms
also have "keys (poly_subst f p) ⊆ (⋃t∈keys p. keys (punit.monom_mult (lookup p t) 0 (subst_pp f t)))"
unfolding poly_subst_def by (rule keys_sum_subset)
finally obtain s where "s ∈ keys p" and "t ∈ keys (punit.monom_mult (lookup p s) 0 (subst_pp f s))" ..
note this(2)
also have "… ⊆ (+) 0 ` keys (subst_pp f s)" by (rule punit.keys_monom_mult_subset[simplified])
also have "… = keys (subst_pp f s)" by simp
finally have "t ∈ keys (subst_pp f s)" .
with ‹s ∈ keys p› show ?thesis ..
qed
lemma in_indets_poly_substE:
assumes "x ∈ indets (poly_subst f p)"
obtains y where "y ∈ indets p" and "x ∈ indets (f y)"
proof -
note assms
also have "indets (poly_subst f p) ⊆ (⋃t∈keys p. indets (punit.monom_mult (lookup p t) 0 (subst_pp f t)))"
unfolding poly_subst_def by (rule indets_sum_subset)
finally obtain t where "t ∈ keys p" and "x ∈ indets (punit.monom_mult (lookup p t) 0 (subst_pp f t))" ..
note this(2)
also have "indets (punit.monom_mult (lookup p t) 0 (subst_pp f t)) ⊆ keys (0::('a ⇒⇩0 nat)) ∪ indets (subst_pp f t)"
by (rule indets_monom_mult_subset)
also have "... = indets (subst_pp f t)" by simp
finally obtain y where "y ∈ keys t" and "x ∈ indets (f y)" by (rule in_indets_subst_ppE)
from this(1) ‹t ∈ keys p› have "y ∈ indets p" by (rule in_indetsI)
from this ‹x ∈ indets (f y)› show ?thesis ..
qed
lemma poly_deg_poly_subst_eq_zeroI:
assumes "⋀x. x ∈ indets p ⟹ poly_deg (f x) = 0"
shows "poly_deg (poly_subst (f::_ ⇒ (('y ⇒⇩0 _) ⇒⇩0 _)) (p::('x ⇒⇩0 _) ⇒⇩0 'b::comm_semiring_1)) = 0"
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
have "poly_deg (poly_subst f p) ≤ Max (poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
unfolding poly_subst_def by (fact poly_deg_sum_le)
also have "... ≤ 0"
proof (rule Max.boundedI)
show "finite (poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
by (simp add: finite_image_iff)
next
from False show "poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p ≠ {}" by simp
next
fix d
assume "d ∈ poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p"
then obtain t where "t ∈ keys p" and d: "d = poly_deg (punit.monom_mult (lookup p t) 0 (subst_pp f t))"
by fastforce
have "d ≤ deg_pm (0::'y ⇒⇩0 nat) + poly_deg (subst_pp f t)"
unfolding d by (fact poly_deg_monom_mult_le)
also have "... = poly_deg (subst_pp f t)" by simp
also have "... = 0" by (rule poly_deg_subst_pp_eq_zeroI, rule assms, erule in_indetsI, fact)
finally show "d ≤ 0" .
qed
finally show ?thesis by simp
qed
lemma poly_deg_poly_subst_le:
assumes "⋀x. x ∈ indets p ⟹ poly_deg (f x) ≤ 1"
shows "poly_deg (poly_subst (f::_ ⇒ (('y ⇒⇩0 _) ⇒⇩0 _)) (p::('x ⇒⇩0 nat) ⇒⇩0 'b::comm_semiring_1)) ≤ poly_deg p"
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
have "poly_deg (poly_subst f p) ≤ Max (poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
unfolding poly_subst_def by (fact poly_deg_sum_le)
also have "... ≤ poly_deg p"
proof (rule Max.boundedI)
show "finite (poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
by (simp add: finite_image_iff)
next
from False show "poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p ≠ {}" by simp
next
fix d
assume "d ∈ poly_deg ` (λt. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p"
then obtain t where "t ∈ keys p" and d: "d = poly_deg (punit.monom_mult (lookup p t) 0 (subst_pp f t))"
by fastforce
have "d ≤ deg_pm (0::'y ⇒⇩0 nat) + poly_deg (subst_pp f t)"
unfolding d by (fact poly_deg_monom_mult_le)
also have "... = poly_deg (subst_pp f t)" by simp
also have "... ≤ deg_pm t" by (rule poly_deg_subst_pp_le, rule assms, erule in_indetsI, fact)
also from ‹t ∈ keys p› have "... ≤ poly_deg p" by (rule poly_deg_max_keys)
finally show "d ≤ poly_deg p" .
qed
finally show ?thesis by simp
qed
lemma subst_pp_cong: "s = t ⟹ (⋀x. x ∈ keys t ⟹ f x = g x) ⟹ subst_pp f s = subst_pp g t"
by (simp add: subst_pp_def)
lemma poly_subst_cong:
assumes "p = q" and "⋀x. x ∈ indets q ⟹ f x = g x"
shows "poly_subst f p = poly_subst g q"
proof (simp add: poly_subst_def assms(1), rule sum.cong)
fix t
assume "t ∈ keys q"
{
fix x
assume "x ∈ keys t"
with ‹t ∈ keys q› have "x ∈ indets q" by (auto simp: indets_def)
hence "f x = g x" by (rule assms(2))
}
thus "punit.monom_mult (lookup q t) 0 (subst_pp f t) = punit.monom_mult (lookup q t) 0 (subst_pp g t)"
by (simp cong: subst_pp_cong)
qed (fact refl)
lemma Polys_homomorphismE:
obtains h where "⋀p q. h (p + q) = h p + h q" and "⋀p q. h (p * q) = h p * h q"
and "⋀p::('x ⇒⇩0 nat) ⇒⇩0 'a::comm_ring_1. h (h p) = h p" and "range h = P[X]"
proof -
let ?f = "λx. if x ∈ X then monomial (1::'a) (Poly_Mapping.single x 1) else 1"
have 1: "poly_subst ?f p = p" if "p ∈ P[X]" for p
proof (rule poly_subst_id)
fix x
assume "x ∈ indets p"
also from that have "… ⊆ X" by (rule PolysD)
finally show "?f x = monomial 1 (Poly_Mapping.single x 1)" by simp
qed
have 2: "poly_subst ?f p ∈ P[X]" for p
proof (intro PolysI_alt subsetI)
fix x
assume "x ∈ indets (poly_subst ?f p)"
then obtain y where "x ∈ indets (?f y)" by (rule in_indets_poly_substE)
thus "x ∈ X" by (simp add: indets_monomial split: if_split_asm)
qed
from poly_subst_plus poly_subst_times show ?thesis
proof
fix p
from 2 show "poly_subst ?f (poly_subst ?f p) = poly_subst ?f p" by (rule 1)
next
show "range (poly_subst ?f) = P[X]"
proof (intro set_eqI iffI)
fix p :: "_ ⇒⇩0 'a"
assume "p ∈ P[X]"
hence "p = poly_subst ?f p" by (simp only: 1)
thus "p ∈ range (poly_subst ?f)" by (rule image_eqI) simp
qed (auto intro: 2)
qed
qed
lemma in_idealE_Polys_finite:
assumes "finite B" and "B ⊆ P[X]" and "p ∈ P[X]" and "(p::('x ⇒⇩0 nat) ⇒⇩0 'a::comm_ring_1) ∈ ideal B"
obtains q where "⋀b. q b ∈ P[X]" and "p = (∑b∈B. q b * b)"
proof -
obtain h where "⋀p q. h (p + q) = h p + h q" and "⋀p q. h (p * q) = h p * h q"
and "⋀p::('x ⇒⇩0 nat) ⇒⇩0 'a. h (h p) = h p" and rng[symmetric]: "range h = P[X]"
by (rule Polys_homomorphismE) blast
from this(1-3) assms obtain q where "⋀b. q b ∈ P[X]" and "p = (∑b∈B. q b * b)"
unfolding rng by (rule in_idealE_homomorphism_finite) blast
thus ?thesis ..
qed
corollary in_idealE_Polys:
assumes "B ⊆ P[X]" and "p ∈ P[X]" and "p ∈ ideal B"
obtains A q where "finite A" and "A ⊆ B" and "⋀b. q b ∈ P[X]" and "p = (∑b∈A. q b * b)"
proof -
from assms(3) obtain A where "finite A" and "A ⊆ B" and "p ∈ ideal A"
by (rule ideal.span_finite_subset)
from this(2) assms(1) have "A ⊆ P[X]" by (rule subset_trans)
with ‹finite A› obtain q where "⋀b. q b ∈ P[X]" and "p = (∑b∈A. q b * b)"
using assms(2) ‹p ∈ ideal A› by (rule in_idealE_Polys_finite) blast
with ‹finite A› ‹A ⊆ B› show ?thesis ..
qed
lemma ideal_induct_Polys [consumes 3, case_names 0 plus]:
assumes "F ⊆ P[X]" and "p ∈ P[X]" and "p ∈ ideal F"
assumes "P 0" and "⋀c q h. c ∈ P[X] ⟹ q ∈ F ⟹ P h ⟹ h ∈ P[X] ⟹ P (c * q + h)"
shows "P (p::('x ⇒⇩0 nat) ⇒⇩0 'a::comm_ring_1)"
proof -
obtain h where "⋀p q. h (p + q) = h p + h q" and "⋀p q. h (p * q) = h p * h q"
and "⋀p::('x ⇒⇩0 nat) ⇒⇩0 'a. h (h p) = h p" and rng[symmetric]: "range h = P[X]"
by (rule Polys_homomorphismE) blast
from this(1-3) assms show ?thesis
unfolding rng by (rule ideal_induct_homomorphism) blast
qed
lemma image_poly_subst_ideal_subset: "poly_subst g ` ideal F ⊆ ideal (poly_subst g ` F)"
proof (intro subsetI, elim imageE)
fix h f
assume h: "h = poly_subst g f"
assume "f ∈ ideal F"
thus "h ∈ ideal (poly_subst g ` F)" unfolding h
proof (induct f rule: ideal.span_induct_alt)
case base
show ?case by (simp add: ideal.span_zero)
next
case (step c f h)
from step.hyps(1) have "poly_subst g f ∈ ideal (poly_subst g ` F)"
by (intro ideal.span_base imageI)
hence "poly_subst g c * poly_subst g f ∈ ideal (poly_subst g ` F)" by (rule ideal.span_scale)
hence "poly_subst g c * poly_subst g f + poly_subst g h ∈ ideal (poly_subst g ` F)"
using step.hyps(2) by (rule ideal.span_add)
thus ?case by (simp only: poly_subst_plus poly_subst_times)
qed
qed
subsection ‹Evaluating Polynomials›
lemma lookup_times_zero:
"lookup (p * q) 0 = lookup p 0 * lookup q (0::'a::{comm_powerprod,ninv_comm_monoid_add})"
proof -
have eq: "(∑v∈keys q. lookup q v when t + v = 0) = (lookup q 0 when t = 0)" for t
proof -
have "(∑v∈keys q. lookup q v when t + v = 0) = (∑v∈keys q ∩ {0}. lookup q v when t + v = 0)"
proof (intro sum.mono_neutral_right ballI)
fix v
assume "v ∈ keys q - keys q ∩ {0}"
hence "v ≠ 0" by blast
hence "t + v ≠ 0" using plus_eq_zero_2 by blast
thus "(lookup q v when t + v = 0) = 0" by simp
qed simp_all
also have "… = (lookup q 0 when t = 0)" by (cases "0 ∈ keys q") (simp_all add: in_keys_iff)
finally show ?thesis .
qed
have "(∑t∈keys p. lookup p t * lookup q 0 when t = 0) =
(∑t∈keys p ∩ {0}. lookup p t * lookup q 0 when t = 0)"
proof (intro sum.mono_neutral_right ballI)
fix t
assume "t ∈ keys p - keys p ∩ {0}"
hence "t ≠ 0" by blast
thus "(lookup p t * lookup q 0 when t = 0) = 0" by simp
qed simp_all
also have "… = lookup p 0 * lookup q 0" by (cases "0 ∈ keys p") (simp_all add: in_keys_iff)
finally show ?thesis by (simp add: lookup_times eq when_distrib)
qed
corollary lookup_prod_zero:
"lookup (prod f I) 0 = (∏i∈I. lookup (f i) (0::_::{comm_powerprod,ninv_comm_monoid_add}))"
by (induct I rule: infinite_finite_induct) (simp_all add: lookup_times_zero)
corollary lookup_power_zero:
"lookup (p ^ k) 0 = lookup p (0::_::{comm_powerprod,ninv_comm_monoid_add}) ^ k"
by (induct k) (simp_all add: lookup_times_zero)
definition poly_eval :: "('x ⇒ 'a) ⇒ (('x ⇒⇩0 nat) ⇒⇩0 'a) ⇒ 'a::comm_semiring_1"
where "poly_eval a p = lookup (poly_subst (λy. monomial (a y) (0::'x ⇒⇩0 nat)) p) 0"
lemma poly_eval_alt: "poly_eval a p = (∑t∈keys p. lookup p t * (∏x∈keys t. a x ^ lookup t x))"
by (simp add: poly_eval_def poly_subst_def lookup_sum lookup_times_zero subst_pp_def
lookup_prod_zero lookup_power_zero flip: times_monomial_left)
lemma poly_eval_monomial: "poly_eval a (monomial c t) = c * (∏x∈keys t. a x ^ lookup t x)"
by (simp add: poly_eval_def poly_subst_monomial subst_pp_def punit.lookup_monom_mult
lookup_prod_zero lookup_power_zero)
lemma poly_eval_zero [simp]: "poly_eval a 0 = 0"
by (simp only: poly_eval_def poly_subst_zero lookup_zero)
lemma poly_eval_zero_left [simp]: "poly_eval 0 p = lookup p 0"
by (simp add: poly_eval_def)
lemma poly_eval_plus: "poly_eval a (p + q) = poly_eval a p + poly_eval a q"
by (simp only: poly_eval_def poly_subst_plus lookup_add)
lemma poly_eval_uminus [simp]: "poly_eval a (- p) = - poly_eval (a::_::comm_ring_1) p"
by (simp only: poly_eval_def poly_subst_uminus lookup_uminus)
lemma poly_eval_minus: "poly_eval a (p - q) = poly_eval a p - poly_eval (a::_::comm_ring_1) q"
by (simp only: poly_eval_def poly_subst_minus lookup_minus)
lemma poly_eval_one [simp]: "poly_eval a 1 = 1"
by (simp add: poly_eval_def lookup_one)
lemma poly_eval_times: "poly_eval a (p * q) = poly_eval a p * poly_eval a q"
by (simp only: poly_eval_def poly_subst_times lookup_times_zero)
lemma poly_eval_power: "poly_eval a (p ^ m) = poly_eval a p ^ m"
by (induct m) (simp_all add: poly_eval_times)
lemma poly_eval_sum: "poly_eval a (sum f I) = (∑i∈I. poly_eval a (f i))"
by (induct I rule: infinite_finite_induct) (simp_all add: poly_eval_plus)
lemma poly_eval_prod: "poly_eval a (prod f I) = (∏i∈I. poly_eval a (f i))"
by (induct I rule: infinite_finite_induct) (simp_all add: poly_eval_times)
lemma poly_eval_cong: "p = q ⟹ (⋀x. x ∈ indets q ⟹ a x = b x) ⟹ poly_eval a p = poly_eval b q"
by (simp add: poly_eval_def cong: poly_subst_cong)
lemma indets_poly_eval_subset:
"indets (poly_eval a p) ⊆ ⋃ (indets ` a ` indets p) ∪ ⋃ (indets ` lookup p ` keys p)"
proof (induct p rule: poly_mapping_plus_induct)
case 1
show ?case by simp
next
case (2 p c t)
have "keys (monomial c t + p) = keys (monomial c t) ∪ keys p"
by (rule keys_plus_eqI) (simp add: 2(2))
with 2(1) have eq1: "keys (monomial c t + p) = insert t (keys p)" by simp
hence eq2: "indets (monomial c t + p) = keys t ∪ indets p" by (simp add: indets_def)
from 2(2) have eq3: "lookup (monomial c t + p) t = c" by (simp add: lookup_add in_keys_iff)
have eq4: "lookup (monomial c t + p) s = lookup p s" if "s ∈ keys p" for s
using that 2(2) by (auto simp: lookup_add lookup_single when_def)
have "indets (poly_eval a (monomial c t + p)) =
indets (c * (∏x∈keys t. a x ^ lookup t x) + poly_eval a p)"
by (simp only: poly_eval_plus poly_eval_monomial)
also have "… ⊆ indets (c * (∏x∈keys t. a x ^ lookup t x)) ∪ indets (poly_eval a p)"
by (fact indets_plus_subset)
also have "… ⊆ indets c ∪ (⋃ (indets ` a ` keys t)) ∪
(⋃ (indets ` a ` indets p) ∪ ⋃ (indets ` lookup p ` keys p))"
proof (intro Un_mono 2(3))
have "indets (c * (∏x∈keys t. a x ^ lookup t x)) ⊆ indets c ∪ indets (∏x∈keys t. a x ^ lookup t x)"
by (fact indets_times_subset)
also have "indets (∏x∈keys t. a x ^ lookup t x) ⊆ (⋃x∈keys t. indets (a x ^ lookup t x))"
by (fact indets_prod_subset)
also have "… ⊆ (⋃x∈keys t. indets (a x))" by (intro UN_mono subset_refl indets_power_subset)
also have "… = ⋃ (indets ` a ` keys t)" by simp
finally show "indets (c * (∏x∈keys t. a x ^ lookup t x)) ⊆ indets c ∪ ⋃ (indets ` a ` keys t)"
by blast
qed
also have "… = ⋃ (indets ` a ` indets (monomial c t + p)) ∪
⋃ (indets ` lookup (monomial c t + p) ` keys (monomial c t + p))"
by (simp add: eq1 eq2 eq3 eq4 Un_commute Un_assoc Un_left_commute)
finally show ?case .
qed
lemma image_poly_eval_ideal: "poly_eval a ` ideal F = ideal (poly_eval a ` F)"
proof (intro image_ideal_eq_surj poly_eval_plus poly_eval_times surjI)
fix x
show "poly_eval a (monomial x 0) = x" by (simp add: poly_eval_monomial)
qed
subsection ‹Replacing Indeterminates›
definition map_indets where "map_indets f = poly_subst (λx. monomial 1 (Poly_Mapping.single (f x) 1))"
lemma
shows map_indets_zero [simp]: "map_indets f 0 = 0"
and map_indets_one [simp]: "map_indets f 1 = 1"
and map_indets_uminus [simp]: "map_indets f (- r) = - map_indets f (r::_ ⇒⇩0 _::comm_ring_1)"
and map_indets_plus: "map_indets f (p + q) = map_indets f p + map_indets f q"
and map_indets_minus: "map_indets f (r - s) = map_indets f r - map_indets f s"
and map_indets_times: "map_indets f (p * q) = map_indets f p * map_indets f q"
and map_indets_power [simp]: "map_indets f (p ^ m) = map_indets f p ^ m"
and map_indets_sum: "map_indets f (sum g A) = (∑a∈A. map_indets f (g a))"
and map_indets_prod: "map_indets f (prod g A) = (∏a∈A. map_indets f (g a))"
by (simp_all add: map_indets_def poly_subst_uminus poly_subst_plus poly_subst_minus poly_subst_times
poly_subst_power poly_subst_sum poly_subst_prod)
lemma map_indets_monomial:
"map_indets f (monomial c t) = monomial c (∑x∈keys t. Poly_Mapping.single (f x) (lookup t x))"
by (simp add: map_indets_def poly_subst_monomial subst_pp_def monomial_power_map_scale
punit.monom_mult_monomial flip: punit.monomial_prod_sum)
lemma map_indets_id: "(⋀x. x ∈ indets p ⟹ f x = x) ⟹ map_indets f p = p"
by (simp add: map_indets_def poly_subst_id)
lemma map_indets_map_indets: "map_indets f (map_indets g p) = map_indets (f ∘ g) p"
by (simp add: map_indets_def poly_subst_poly_subst poly_subst_monomial subst_pp_single)
lemma map_indets_cong: "p = q ⟹ (⋀x. x ∈ indets q ⟹ f x = g x) ⟹ map_indets f p = map_indets g q"
unfolding map_indets_def by (simp cong: poly_subst_cong)
lemma poly_subst_map_indets: "poly_subst f (map_indets g p) = poly_subst (f ∘ g) p"
by (simp add: map_indets_def poly_subst_poly_subst poly_subst_monomial subst_pp_single comp_def)
lemma poly_eval_map_indets: "poly_eval a (map_indets g p) = poly_eval (a ∘ g) p"
by (simp add: poly_eval_def poly_subst_map_indets comp_def)
(simp add: poly_subst_def lookup_sum lookup_times_zero subst_pp_def lookup_prod_zero
lookup_power_zero flip: times_monomial_left)
lemma map_indets_inverseE_Polys:
assumes "inj_on f X" and "p ∈ P[X]"
shows "map_indets (the_inv_into X f) (map_indets f p) = p"
unfolding map_indets_map_indets
proof (rule map_indets_id)
fix x
assume "x ∈ indets p"
also from assms(2) have "… ⊆ X" by (rule PolysD)
finally show "(the_inv_into X f ∘ f) x = x" using assms(1) by (auto intro: the_inv_into_f_f)
qed
lemma map_indets_inverseE:
assumes "inj f"
obtains g where "g = the_inv f" and "g ∘ f = id" and "map_indets g ∘ map_indets f = id"
proof -
define g where "g = the_inv f"
moreover from assms have eq: "g ∘ f = id" by (auto intro!: ext the_inv_f_f simp: g_def)
moreover have "map_indets g ∘ map_indets f = id"
by (rule ext) (simp add: map_indets_map_indets eq map_indets_id)
ultimately show ?thesis ..
qed
lemma indets_map_indets_subset: "indets (map_indets f (p::_ ⇒⇩0 'a::comm_semiring_1)) ⊆ f ` indets p"
proof
fix x
assume "x ∈ indets (map_indets f p)"
then obtain y where "y ∈ indets p" and "x ∈ indets (monomial (1::'a) (Poly_Mapping.single (f y) 1))"
unfolding map_indets_def by (rule in_indets_poly_substE)
from this(2) have x: "x = f y" by (simp add: indets_monomial)
from ‹y ∈ indets p› show "x ∈ f ` indets p" unfolding x by (rule imageI)
qed
corollary map_indets_in_Polys: "map_indets f p ∈ P[f ` indets p]"
using indets_map_indets_subset by (rule PolysI_alt)
lemma indets_map_indets:
assumes "inj_on f (indets p)"
shows "indets (map_indets f p) = f ` indets p"
using indets_map_indets_subset
proof (rule subset_antisym)
let ?g = "the_inv_into (indets p) f"
have "p = map_indets ?g (map_indets f p)" unfolding map_indets_map_indets
by (rule sym, rule map_indets_id) (simp add: assms the_inv_into_f_f)
also have "indets … ⊆ ?g ` indets (map_indets f p)" by (fact indets_map_indets_subset)
finally have "f ` indets p ⊆ f ` ?g ` indets (map_indets f p)" by (rule image_mono)
also have "… = (λx. x) ` indets (map_indets f p)" unfolding image_image using refl
proof (rule image_cong)
fix x
assume "x ∈ indets (map_indets f p)"
with indets_map_indets_subset have "x ∈ f ` indets p" ..
with assms show "f (?g x) = x" by (rule f_the_inv_into_f)
qed
finally show "f ` indets p ⊆ indets (map_indets f p)" by simp
qed
lemma image_map_indets_Polys: "map_indets f ` P[X] = (P[f ` X]::(_ ⇒⇩0 'a::comm_semiring_1) set)"
proof (intro set_eqI iffI)
fix p :: "_ ⇒⇩0 'a"
assume "p ∈ map_indets f ` P[X]"
then obtain q where "q ∈ P[X]" and "p = map_indets f q" ..
note this(2)
also have "map_indets f q ∈ P[f ` indets q]" by (fact map_indets_in_Polys)
also from ‹q ∈ _› have "… ⊆ P[f ` X]" by (auto intro!: Polys_mono imageI dest: PolysD)
finally show "p ∈ P[f ` X]" .
next
fix p :: "_ ⇒⇩0 'a"
assume "p ∈ P[f ` X]"
define g where "g = (λy. SOME x. x ∈ X ∧ f x = y)"
have "g y ∈ X ∧ f (g y) = y" if "y ∈ indets p" for y
proof -
note that
also from ‹p ∈ _› have "indets p ⊆ f ` X" by (rule PolysD)
finally obtain x where "x ∈ X" and "y = f x" ..
hence "x ∈ X ∧ f x = y" by simp
thus ?thesis unfolding g_def by (rule someI)
qed
hence 1: "g y ∈ X" and 2: "f (g y) = y" if "y ∈ indets p" for y using that by simp_all
show "p ∈ map_indets f ` P[X]"
proof
show "p = map_indets f (map_indets g p)"
by (rule sym) (simp add: map_indets_map_indets map_indets_id 2)
next
have "map_indets g p ∈ P[g ` indets p]" by (fact map_indets_in_Polys)
also have "… ⊆ P[X]" by (auto intro!: Polys_mono 1)
finally show "map_indets g p ∈ P[X]" .
qed
qed
corollary range_map_indets: "range (map_indets f) = P[range f]"
proof -
have "range (map_indets f) = map_indets f ` P[UNIV]" by simp
also have "… = P[range f]" by (simp only: image_map_indets_Polys)
finally show ?thesis .
qed
lemma in_keys_map_indetsE:
assumes "t ∈ keys (map_indets f (p::_ ⇒⇩0 'a::comm_semiring_1))"
obtains s where "s ∈ keys p" and "t = (∑x∈keys s. Poly_Mapping.single (f x) (lookup s x))"
proof -
let ?f = "(λx. monomial (1::'a) (Poly_Mapping.single (f x) 1))"
from assms obtain s where "s ∈ keys p" and "t ∈ keys (subst_pp ?f s)" unfolding map_indets_def
by (rule in_keys_poly_substE)
note this(2)
also have "… ⊆ {∑x∈keys s. Poly_Mapping.single (f x) (lookup s x)}"
by (simp add: subst_pp_def monomial_power_map_scale flip: punit.monomial_prod_sum)
finally have "t = (∑x∈keys s. Poly_Mapping.single (f x) (lookup s x))" by simp
with ‹s ∈ keys p› show ?thesis ..
qed
lemma keys_map_indets_subset:
"keys (map_indets f p) ⊆ (λt. ∑x∈keys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p"
by (auto elim: in_keys_map_indetsE)
lemma keys_map_indets:
assumes "inj_on f (indets p)"
shows "keys (map_indets f p) = (λt. ∑x∈keys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p"
using keys_map_indets_subset
proof (rule subset_antisym)
let ?g = "the_inv_into (indets p) f"
have "p = map_indets ?g (map_indets f p)" unfolding map_indets_map_indets
by (rule sym, rule map_indets_id) (simp add: assms the_inv_into_f_f)
also have "keys … ⊆ (λt. ∑x∈keys t. monomial (lookup t x) (?g x)) ` keys (map_indets f p)"
by (rule keys_map_indets_subset)
finally have "(λt. ∑x∈keys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p ⊆
(λt. ∑x∈keys t. Poly_Mapping.single (f x) (lookup t x)) `
(λt. ∑x∈keys t. Poly_Mapping.single (?g x) (lookup t x)) ` keys (map_indets f p)"
by (rule image_mono)
also from refl have "… = (λt. ∑x. Poly_Mapping.single (f x) (lookup t x)) `
(λt. ∑x∈keys t. Poly_Mapping.single (?g x) (lookup t x)) ` keys (map_indets f p)"
by (rule image_cong)
(smt Sum_any.conditionalize Sum_any.cong finite_keys not_in_keys_iff_lookup_eq_zero single_zero)
also have "… = (λt. t) ` keys (map_indets f p)" unfolding image_image using refl
proof (rule image_cong)
fix t
assume "t ∈ keys (map_indets f p)"
have "(∑x. monomial (lookup (∑y∈keys t. Poly_Mapping.single (?g y) (lookup t y)) x) (f x)) =
(∑x. ∑y∈keys t. monomial (lookup t y when ?g y = x) (f x))"
by (simp add: lookup_sum lookup_single monomial_sum)
also have "… = (∑x∈indets p. ∑y∈keys t. Poly_Mapping.single (f x) (lookup t y when ?g y = x))"
proof (intro Sum_any.expand_superset finite_indets subsetI)
fix x
assume "x ∈ {a. (∑y∈keys t. Poly_Mapping.single (f a) (lookup t y when ?g y = a)) ≠ 0}"
hence "(∑y∈keys t. Poly_Mapping.single (f x) (lookup t y when ?g y = x)) ≠ 0" by simp
then obtain y where "y ∈ keys t" and *: "Poly_Mapping.single (f x) (lookup t y when ?g y = x) ≠ 0"
by (rule sum.not_neutral_contains_not_neutral)
from this(1) have "y ∈ indets (map_indets f p)" using ‹t ∈ _› by (rule in_indetsI)
with indets_map_indets_subset have "y ∈ f ` indets p" ..
from * have "x = ?g y" by (simp add: when_def split: if_split_asm)
also from assms ‹y ∈ f ` indets p› subset_refl have "… ∈ indets p" by (rule the_inv_into_into)
finally show "x ∈ indets p" .
qed
also have "… = (∑y∈keys t. ∑x∈indets p. Poly_Mapping.single (f x) (lookup t y when ?g y = x))"
by (fact sum.swap)
also from refl have "… = (∑y∈keys t. Poly_Mapping.single y (lookup t y))"
proof (rule sum.cong)
fix x
assume "x ∈ keys t"
hence "x ∈ indets (map_indets f p)" using ‹t ∈ _› by (rule in_indetsI)
with indets_map_indets_subset have "x ∈ f ` indets p" ..
with assms have "?g x ∈ indets p" using subset_refl by (rule the_inv_into_into)
hence "{?g x} ⊆ indets p" by simp
with finite_indets have "(∑y∈indets p. Poly_Mapping.single (f y) (lookup t x when ?g x = y)) =
(∑y∈{?g x}. Poly_Mapping.single (f y) (lookup t x when ?g x = y))"
by (rule sum.mono_neutral_right) (simp add: monomial_0_iff when_def)
also from assms ‹x ∈ f ` indets p› have "… = Poly_Mapping.single x (lookup t x)"
by (simp add: f_the_inv_into_f)
finally show "(∑y∈indets p. Poly_Mapping.single (f y) (lookup t x when ?g x = y)) =
Poly_Mapping.single x (lookup t x)" .
qed
also have "… = t" by (fact poly_mapping_sum_monomials)
finally show "(∑x. monomial (lookup (∑y∈keys t. Poly_Mapping.single (?g y) (lookup t y)) x) (f x)) = t" .
qed
also have "… = keys (map_indets f p)" by simp
finally show "(λt. ∑x∈keys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p ⊆ keys (map_indets f p)" .
qed
lemma poly_deg_map_indets_le: "poly_deg (map_indets f p) ≤ poly_deg p"
proof (rule poly_deg_leI)
fix t
assume "t ∈ keys (map_indets f p)"
then obtain s where "s ∈ keys p" and t: "t = (∑x∈keys s. Poly_Mapping.single (f x) (lookup s x))"
by (rule in_keys_map_indetsE)
from this(1) have "deg_pm s ≤ poly_deg p" by (rule poly_deg_max_keys)
thus "deg_pm t ≤ poly_deg p"
by (simp add: t deg_pm_sum deg_pm_single deg_pm_superset[OF subset_refl])
qed
lemma poly_deg_map_indets:
assumes "inj_on f (indets p)"
shows "poly_deg (map_indets f p) = poly_deg p"
proof -
from assms have "deg_pm ` keys (map_indets f p) = deg_pm ` keys p"
by (simp add: keys_map_indets image_image deg_pm_sum deg_pm_single
flip: deg_pm_superset[OF subset_refl])
thus ?thesis by (auto simp: poly_deg_def)
qed
lemma map_indets_inj_on_PolysI:
assumes "inj_on (f::'x ⇒ 'y) X"
shows "inj_on ((map_indets f)::_ ⇒ _ ⇒⇩0 'a::comm_semiring_1) P[X]"
proof (rule inj_onI)
fix p q :: "_ ⇒⇩0 'a"
assume "p ∈ P[X]"
with assms have 1: "map_indets (the_inv_into X f) (map_indets f p) = p" (is "map_indets ?g _ = _")
by (rule map_indets_inverseE_Polys)
assume "q ∈ P[X]"
with assms have "map_indets ?g (map_indets f q) = q" by (rule map_indets_inverseE_Polys)
moreover assume "map_indets f p = map_indets f q"
ultimately show "p = q" using 1 by (simp add: map_indets_map_indets)
qed
lemma map_indets_injI:
assumes "inj f"
shows "inj (map_indets f)"
proof -
from assms have "inj_on (map_indets f) P[UNIV]" by (rule map_indets_inj_on_PolysI)
thus ?thesis by simp
qed
lemma image_map_indets_ideal:
assumes "inj f"
shows "map_indets f ` ideal F = ideal (map_indets f ` (F::(_ ⇒⇩0 'a::comm_ring_1) set)) ∩ P[range f]"
proof
from map_indets_plus map_indets_times have "map_indets f ` ideal F ⊆ ideal (map_indets f ` F)"
by (rule image_ideal_subset)
moreover from subset_UNIV have "map_indets f ` ideal F ⊆ range (map_indets f)" by (rule image_mono)
ultimately show "map_indets f ` ideal F ⊆ ideal (map_indets f ` F) ∩ P[range f]"
unfolding range_map_indets by blast
next
show "ideal (map_indets f ` F) ∩ P[range f] ⊆ map_indets f ` ideal F"
proof
fix p
assume "p ∈ ideal (map_indets f ` F) ∩ P[range f]"
hence "p ∈ ideal (map_indets f ` F)" and "p ∈ range (map_indets f)"
by (simp_all add: range_map_indets)
from this(1) obtain F0 q where "F0 ⊆ map_indets f ` F" and p: "p = (∑f'∈F0. q f' * f')"
by (rule ideal.spanE)
from this(1) obtain F' where "F' ⊆ F" and F0: "F0 = map_indets f ` F'" by (rule subset_imageE)
from assms obtain g where "map_indets g ∘ map_indets f = (id::_ ⇒ _ ⇒⇩0 'a)"
by (rule map_indets_inverseE)
hence eq: "map_indets g (map_indets f p') = p'" for p'::"_ ⇒⇩0 'a"
by (simp add: pointfree_idE)
from assms have "inj (map_indets f)" by (rule map_indets_injI)
from this subset_UNIV have "inj_on (map_indets f) F'" by (rule inj_on_subset)
from ‹p ∈ range _› obtain p' where "p = map_indets f p'" ..
hence "p = map_indets f (map_indets g p)" by (simp add: eq)
also from ‹inj_on _ F'› have "… = map_indets f (∑f'∈F'. map_indets g (q (map_indets f f')) * f')"
by (simp add: p F0 sum.reindex map_indets_sum map_indets_times eq)
finally have "p = map_indets f (∑f'∈F'. map_indets g (q (map_indets f f')) * f')" .
moreover have "(∑f'∈F'. map_indets g (q (map_indets f f')) * f') ∈ ideal F"
proof
show "(∑f'∈F'. map_indets g (q (map_indets f f')) * f') ∈ ideal F'" by (rule ideal.sum_in_spanI)
next
from ‹F' ⊆ F› show "ideal F' ⊆ ideal F" by (rule ideal.span_mono)
qed
ultimately show "p ∈ map_indets f ` ideal F" by (rule image_eqI)
qed
qed
subsection ‹Homogeneity›
definition homogeneous :: "(('x ⇒⇩0 nat) ⇒⇩0 'a::zero) ⇒ bool"
where "homogeneous p ⟷ (∀s∈keys p. ∀t∈keys p. deg_pm s = deg_pm t)"
definition hom_component :: "(('x ⇒⇩0 nat) ⇒⇩0 'a) ⇒ nat ⇒ (('x ⇒⇩0 nat) ⇒⇩0 'a::zero)"
where "hom_component p n = except p {t. deg_pm t ≠ n}"
definition hom_components :: "(('x ⇒⇩0 nat) ⇒⇩0 'a) ⇒ (('x ⇒⇩0 nat) ⇒⇩0 'a::zero) set"
where "hom_components p = hom_component p ` deg_pm ` keys p"
definition homogeneous_set :: "(('x ⇒⇩0 nat) ⇒⇩0 'a::zero) set ⇒ bool"
where "homogeneous_set A ⟷ (∀a∈A. ∀n. hom_component a n ∈ A)"
lemma homogeneousI: "(⋀s t. s ∈ keys p ⟹ t ∈ keys p ⟹ deg_pm s = deg_pm t) ⟹ homogeneous p"
unfolding homogeneous_def by blast
lemma homogeneousD: "homogeneous p ⟹ s ∈ keys p ⟹ t ∈ keys p ⟹ deg_pm s = deg_pm t"
unfolding homogeneous_def by blast
lemma homogeneousD_poly_deg:
assumes "homogeneous p" and "t ∈ keys p"
shows "deg_pm t = poly_deg p"
proof (rule antisym)
from assms(2) show "deg_pm t ≤ poly_deg p" by (rule poly_deg_max_keys)
next
show "poly_deg p ≤ deg_pm t"
proof (rule poly_deg_leI)
fix s
assume "s ∈ keys p"
with assms(1) have "deg_pm s = deg_pm t" using assms(2) by (rule homogeneousD)
thus "deg_pm s ≤ deg_pm t" by simp
qed
qed
lemma homogeneous_monomial [simp]: "homogeneous (monomial c t)"
by (auto split: if_split_asm intro: homogeneousI)
corollary homogeneous_zero [simp]: "homogeneous 0" and homogeneous_one [simp]: "homogeneous 1"
by (simp_all only: homogeneous_monomial flip: single_zero[of 0] single_one)
lemma homogeneous_uminus_iff [simp]: "homogeneous (- p) ⟷ homogeneous p"
by (auto intro!: homogeneousI dest: homogeneousD simp: keys_uminus)
lemma homogeneous_monom_mult: "homogeneous p ⟹ homogeneous (punit.monom_mult c t p)"
by (auto intro!: homogeneousI elim!: punit.keys_monom_multE simp: deg_pm_plus dest: homogeneousD)
lemma homogeneous_monom_mult_rev:
assumes "c ≠ (0::'a::semiring_no_zero_divisors)" and "homogeneous (punit.monom_mult c t p)"
shows "homogeneous p"
proof (rule homogeneousI)
fix s s'
assume "s ∈ keys p"
hence 1: "t + s ∈ keys (punit.monom_mult c t p)"
using assms(1) by (rule punit.keys_monom_multI[simplified])
assume "s' ∈ keys p"
hence "t + s' ∈ keys (punit.monom_mult c t p)"
using assms(1) by (rule punit.keys_monom_multI[simplified])
with assms(2) 1 have "deg_pm (t + s) = deg_pm (t + s')" by (rule homogeneousD)
thus "deg_pm s = deg_pm s'" by (simp add: deg_pm_plus)
qed
lemma homogeneous_times:
assumes "homogeneous p" and "homogeneous q"
shows "homogeneous (p * q)"
proof (rule homogeneousI)
fix s t
assume "s ∈ keys (p * q)"
then obtain sp sq where sp: "sp ∈ keys p" and sq: "sq ∈ keys q" and s: "s = sp + sq"
by (rule in_keys_timesE)
assume "t ∈ keys (p * q)"
then obtain tp tq where tp: "tp ∈ keys p" and tq: "tq ∈ keys q" and t: "t = tp + tq"
by (rule in_keys_timesE)
from assms(1) sp tp have "deg_pm sp = deg_pm tp" by (rule homogeneousD)
moreover from assms(2) sq tq have "deg_pm sq = deg_pm tq" by (rule homogeneousD)
ultimately show "deg_pm s = deg_pm t" by (simp only: s t deg_pm_plus)
qed
lemma lookup_hom_component: "lookup (hom_component p n) = (λt. lookup p t when deg_pm t = n)"
by (rule ext) (simp add: hom_component_def lookup_except)
lemma keys_hom_component: "keys (hom_component p n) = {t. t ∈ keys p ∧ deg_pm t = n}"
by (auto simp: hom_component_def keys_except)
lemma keys_hom_componentD:
assumes "t ∈ keys (hom_component p n)"
shows "t ∈ keys p" and "deg_pm t = n"
using assms by (simp_all add: keys_hom_component)
lemma homogeneous_hom_component: "homogeneous (hom_component p n)"
by (auto dest: keys_hom_componentD intro: homogeneousI)
lemma hom_component_zero [simp]: "hom_component 0 = 0"
by (rule ext) (simp add: hom_component_def)
lemma hom_component_zero_iff: "hom_component p n = 0 ⟷ (∀t∈keys p. deg_pm t ≠ n)"
by (metis (mono_tags, lifting) empty_iff keys_eq_empty_iff keys_hom_component mem_Collect_eq subsetI subset_antisym)
lemma hom_component_uminus [simp]: "hom_component (- p) = - hom_component p"
by (intro ext poly_mapping_eqI) (simp add: hom_component_def lookup_except)
lemma hom_component_plus: "hom_component (p + q) n = hom_component p n + hom_component q n"
by (rule poly_mapping_eqI) (simp add: hom_component_def lookup_except lookup_add)
lemma hom_component_minus: "hom_component (p - q) n = hom_component p n - hom_component q n"
by (rule poly_mapping_eqI) (simp add: hom_component_def lookup_except lookup_minus)
lemma hom_component_monom_mult:
"punit.monom_mult c t (hom_component p n) = hom_component (punit.monom_mult c t p) (deg_pm t + n)"
by (auto simp: hom_component_def lookup_except punit.lookup_monom_mult deg_pm_minus deg_pm_mono intro!: poly_mapping_eqI)
lemma hom_component_inject:
assumes "t ∈ keys p" and "hom_component p (deg_pm t) = hom_component p n"
shows "deg_pm t = n"
proof -
from assms(1) have "t ∈ keys (hom_component p (deg_pm t))" by (simp add: keys_hom_component)
hence "0 ≠ lookup (hom_component p (deg_pm t)) t" by (simp add: in_keys_iff)
also have "lookup (hom_component p (deg_pm t)) t = lookup (hom_component p n) t"
by (simp only: assms(2))
also have "… = (lookup p t when deg_pm t = n)" by (simp only: lookup_hom_component)
finally show ?thesis by simp
qed
lemma hom_component_of_homogeneous:
assumes "homogeneous p"
shows "hom_component p n = (p when n = poly_deg p)"
proof (cases "n = poly_deg p")
case True
have "hom_component p n = p"
proof (rule poly_mapping_eqI)
fix t
show "lookup (hom_component p n) t = lookup p t"
proof (cases "t ∈ keys p")
case True
with assms have "deg_pm t = n" unfolding ‹n = poly_deg p› by (rule homogeneousD_poly_deg)
thus ?thesis by (simp add: lookup_hom_component)
next
case False
moreover from this have "t ∉ keys (hom_component p n)" by (simp add: keys_hom_component)
ultimately show ?thesis by (simp add: in_keys_iff)
qed
qed
with True show ?thesis by simp
next
case False
have "hom_component p n = 0" unfolding hom_component_zero_iff
proof (intro ballI notI)
fix t
assume "t ∈ keys p"
with assms have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
moreover assume "deg_pm t = n"
ultimately show False using False by simp
qed
with False show ?thesis by simp
qed
lemma hom_components_zero [simp]: "hom_components 0 = {}"
by (simp add: hom_components_def)
lemma hom_components_zero_iff [simp]: "hom_components p = {} ⟷ p = 0"
by (simp add: hom_components_def)
lemma hom_components_uminus: "hom_components (- p) = uminus ` hom_components p"
by (simp add: hom_components_def keys_uminus image_image)
lemma hom_components_monom_mult:
"hom_components (punit.monom_mult c t p) = (if c = 0 then {} else punit.monom_mult c t ` hom_components p)"
for c::"'a::semiring_no_zero_divisors"
by (simp add: hom_components_def punit.keys_monom_mult image_image deg_pm_plus hom_component_monom_mult)
lemma hom_componentsI: "q = hom_component p (deg_pm t) ⟹ t ∈ keys p ⟹ q ∈ hom_components p"
unfolding hom_components_def by blast
lemma hom_componentsE:
assumes "q ∈ hom_components p"
obtains t where "t ∈ keys p" and "q = hom_component p (deg_pm t)"
using assms unfolding hom_components_def by blast
lemma hom_components_of_homogeneous:
assumes "homogeneous p"
shows "hom_components p = (if p = 0 then {} else {p})"
proof (split if_split, intro conjI impI)
assume "p ≠ 0"
have "deg_pm ` keys p = {poly_deg p}"
proof (rule set_eqI)
fix n
have "n ∈ deg_pm ` keys p ⟷ n = poly_deg p"
proof
assume "n ∈ deg_pm ` keys p"
then obtain t where "t ∈ keys p" and "n = deg_pm t" ..
from assms this(1) have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
thus "n = poly_deg p" by (simp only: ‹n = deg_pm t›)
next
assume "n = poly_deg p"
from ‹p ≠ 0› have "keys p ≠ {}" by simp
then obtain t where "t ∈ keys p" by blast
with assms have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
hence "n = deg_pm t" by (simp only: ‹n = poly_deg p›)
with ‹t ∈ keys p› show "n ∈ deg_pm ` keys p" by (rule rev_image_eqI)
qed
thus "n ∈ deg_pm ` keys p ⟷ n ∈ {poly_deg p}" by simp
qed
with assms show "hom_components p = {p}"
by (simp add: hom_components_def hom_component_of_homogeneous)
qed simp
lemma finite_hom_components: "finite (hom_components p)"
unfolding hom_components_def using finite_keys by (intro finite_imageI)
lemma hom_components_homogeneous: "q ∈ hom_components p ⟹ homogeneous q"
by (elim hom_componentsE) (simp only: homogeneous_hom_component)
lemma hom_components_nonzero: "q ∈ hom_components p ⟹ q ≠ 0"
by (auto elim!: hom_componentsE simp: hom_component_zero_iff)
lemma deg_pm_hom_components:
assumes "q1 ∈ hom_components p" and "q2 ∈ hom_components p" and "t1 ∈ keys q1" and "t2 ∈ keys q2"
shows "deg_pm t1 = deg_pm t2 ⟷ q1 = q2"
proof -
from assms(1) obtain s1 where "s1 ∈ keys p" and q1: "q1 = hom_component p (deg_pm s1)"
by (rule hom_componentsE)
from assms(3) have t1: "deg_pm t1 = deg_pm s1" unfolding q1 by (rule keys_hom_componentD)
from assms(2) obtain s2 where "s2 ∈ keys p" and q2: "q2 = hom_component p (deg_pm s2)"
by (rule hom_componentsE)
from assms(4) have t2: "deg_pm t2 = deg_pm s2" unfolding q2 by (rule keys_hom_componentD)
from ‹s1 ∈ keys p› show ?thesis by (auto simp: q1 q2 t1 t2 dest: hom_component_inject)
qed
lemma poly_deg_hom_components:
assumes "q1 ∈ hom_components p" and "q2 ∈ hom_components p"
shows "poly_deg q1 = poly_deg q2 ⟷ q1 = q2"
proof -
from assms(1) have "homogeneous q1" and "q1 ≠ 0"
by (rule hom_components_homogeneous, rule hom_components_nonzero)
from this(2) have "keys q1 ≠ {}" by simp
then obtain t1 where "t1 ∈ keys q1" by blast
with ‹homogeneous q1› have t1: "deg_pm t1 = poly_deg q1" by (rule homogeneousD_poly_deg)
from assms(2) have "homogeneous q2" and "q2 ≠ 0"
by (rule hom_components_homogeneous, rule hom_components_nonzero)
from this(2) have "keys q2 ≠ {}" by simp
then obtain t2 where "t2 ∈ keys q2" by blast
with ‹homogeneous q2› have t2: "deg_pm t2 = poly_deg q2" by (rule homogeneousD_poly_deg)
from assms ‹t1 ∈ keys q1› ‹t2 ∈ keys q2› have "deg_pm t1 = deg_pm t2 ⟷ q1 = q2"
by (rule deg_pm_hom_components)
thus ?thesis by (simp only: t1 t2)
qed
lemma hom_components_keys_disjoint:
assumes "q1 ∈ hom_components p" and "q2 ∈ hom_components p" and "q1 ≠ q2"
shows "keys q1 ∩ keys q2 = {}"
proof (rule ccontr)
assume "keys q1 ∩ keys q2 ≠ {}"
then obtain t where "t ∈ keys q1" and "t ∈ keys q2" by blast
with assms(1, 2) have "deg_pm t = deg_pm t ⟷ q1 = q2" by (rule deg_pm_hom_components)
with assms(3) show False by simp
qed
lemma Keys_hom_components: "Keys (hom_components p) = keys p"
by (auto simp: Keys_def hom_components_def keys_hom_component)
lemma lookup_hom_components: "q ∈ hom_components p ⟹ t ∈ keys q ⟹ lookup q t = lookup p t"
by (auto elim!: hom_componentsE simp: keys_hom_component lookup_hom_component)
lemma poly_deg_hom_components_le:
assumes "q ∈ hom_components p"
shows "poly_deg q ≤ poly_deg p"
proof (rule poly_deg_leI)
fix t
assume "t ∈ keys q"
also from assms have "… ⊆ Keys (hom_components p)" by (rule keys_subset_Keys)
also have "… = keys p" by (fact Keys_hom_components)
finally show "deg_pm t ≤ poly_deg p" by (rule poly_deg_max_keys)
qed
lemma sum_hom_components: "∑(hom_components p) = p"
proof (rule poly_mapping_eqI)
fix t
show "lookup (∑(hom_components p)) t = lookup p t" unfolding lookup_sum
proof (cases "t ∈ keys p")
case True
also have "keys p = Keys (hom_components p)" by (simp only: Keys_hom_components)
finally obtain q where q: "q ∈ hom_components p" and t: "t ∈ keys q" by (rule in_KeysE)
from this(1) have "(∑q0∈hom_components p. lookup q0 t) =
(∑q0∈insert q (hom_components p). lookup q0 t)"
by (simp only: insert_absorb)
also from finite_hom_components have "… = lookup q t + (∑q0∈hom_components p - {q}. lookup q0 t)"
by (rule sum.insert_remove)
also from q t have "… = lookup p t + (∑q0∈hom_components p - {q}. lookup q0 t)"
by (simp only: lookup_hom_components)
also have "(∑q0∈hom_components p - {q}. lookup q0 t) = 0"
proof (intro sum.neutral ballI)
fix q0
assume "q0 ∈ hom_components p - {q}"
hence "q0 ∈ hom_components p" and "q ≠ q0" by blast+
with q have "keys q ∩ keys q0 = {}" by (rule hom_components_keys_disjoint)
with t have "t ∉ keys q0" by blast
thus "lookup q0 t = 0" by (simp add: in_keys_iff)
qed
finally show "(∑q∈hom_components p. lookup q t) = lookup p t" by simp
next
case False
hence "t ∉ Keys (hom_components p)" by (simp add: Keys_hom_components)
hence "∀q∈hom_components p. lookup q t = 0" by (simp add: Keys_def in_keys_iff)
hence "(∑q∈hom_components p. lookup q t) = 0" by (rule sum.neutral)
also from False have "… = lookup p t" by (simp add: in_keys_iff)
finally show "(∑q∈hom_components p. lookup q t) = lookup p t" .
qed
qed
lemma homogeneous_setI: "(⋀a n. a ∈ A ⟹ hom_component a n ∈ A) ⟹ homogeneous_set A"
by (simp add: homogeneous_set_def)
lemma homogeneous_setD: "homogeneous_set A ⟹ a ∈ A ⟹ hom_component a n ∈ A"
by (simp add: homogeneous_set_def)
lemma homogeneous_set_Polys: "homogeneous_set (P[X]::(_ ⇒⇩0 'a::zero) set)"
proof (intro homogeneous_setI PolysI subsetI)
fix p::"_ ⇒⇩0 'a" and n t
assume "p ∈ P[X]"
assume "t ∈ keys (hom_component p n)"
hence "t ∈ keys p" by (rule keys_hom_componentD)
also from ‹p ∈ P[X]› have "… ⊆ .[X]" by (rule PolysD)
finally show "t ∈ .[X]" .
qed
lemma homogeneous_set_IntI: "homogeneous_set A ⟹ homogeneous_set B ⟹ homogeneous_set (A ∩ B)"
by (simp add: homogeneous_set_def)
lemma homogeneous_setD_hom_components:
assumes "homogeneous_set A" and "a ∈ A" and "b ∈ hom_components a"
shows "b ∈ A"
proof -
from assms(3) obtain t::"'a ⇒⇩0 nat" where "b = hom_component a (deg_pm t)"
by (rule hom_componentsE)
also from assms(1, 2) have "… ∈ A" by (rule homogeneous_setD)
finally show ?thesis .
qed
lemma zero_in_homogeneous_set:
assumes "homogeneous_set A" and "A ≠ {}"
shows "0 ∈ A"
proof -
from assms(2) obtain a where "a ∈ A" by blast
have "lookup a t = 0" if "deg_pm t = Suc (poly_deg a)" for t
proof (rule ccontr)
assume "lookup a t ≠ 0"
hence "t ∈ keys a" by (simp add: in_keys_iff)
hence "deg_pm t ≤ poly_deg a" by (rule poly_deg_max_keys)
thus False by (simp add: that)
qed
hence "0 = hom_component a (Suc (poly_deg a))"
by (intro poly_mapping_eqI) (simp add: lookup_hom_component when_def)
also from assms(1) ‹a ∈ A› have "… ∈ A" by (rule homogeneous_setD)
finally show ?thesis .
qed
lemma homogeneous_ideal:
assumes "⋀f. f ∈ F ⟹ homogeneous f" and "p ∈ ideal F"
shows "hom_component p n ∈ ideal F"
proof -
from assms(2) have "p ∈ punit.pmdl F" by simp
thus ?thesis
proof (induct p rule: punit.pmdl_induct)
case module_0
show ?case by (simp add: ideal.span_zero)
next
case (module_plus a f c t)
let ?f = "punit.monom_mult c t f"
from module_plus.hyps(3) have "f ∈ punit.pmdl F" by (simp add: ideal.span_base)
hence *: "?f ∈ punit.pmdl F" by (rule punit.pmdl_closed_monom_mult)
from module_plus.hyps(3) have "homogeneous f" by (rule assms(1))
hence "homogeneous ?f" by (rule homogeneous_monom_mult)
hence "hom_component ?f n = (?f when n = poly_deg ?f)" by (rule hom_component_of_homogeneous)
also from * have "… ∈ ideal F" by (simp add: when_def ideal.span_zero)
finally have "hom_component ?f n ∈ ideal F" .
with module_plus.hyps(2) show ?case unfolding hom_component_plus by (rule ideal.span_add)
qed
qed
corollary homogeneous_set_homogeneous_ideal:
"(⋀f. f ∈ F ⟹ homogeneous f) ⟹ homogeneous_set (ideal F)"
by (auto intro: homogeneous_setI homogeneous_ideal)
corollary homogeneous_ideal':
assumes "⋀f. f ∈ F ⟹ homogeneous f" and "p ∈ ideal F" and "q ∈ hom_components p"
shows "q ∈ ideal F"
using _ assms(2, 3)
proof (rule homogeneous_setD_hom_components)
from assms(1) show "homogeneous_set (ideal F)" by (rule homogeneous_set_homogeneous_ideal)
qed
lemma homogeneous_idealE_homogeneous:
assumes "⋀f. f ∈ F ⟹ homogeneous f" and "p ∈ ideal F" and "homogeneous p"
obtains F' q where "finite F'" and "F' ⊆ F" and "p = (∑f∈F'. q f * f)" and "⋀f. homogeneous (q f)"
and "⋀f. f ∈ F' ⟹ poly_deg (q f * f) = poly_deg p" and "⋀f. f ∉ F' ⟹ q f = 0"
proof -
from assms(2) obtain F'' q' where "finite F''" and "F'' ⊆ F" and p: "p = (∑f∈F''. q' f * f)"
by (rule ideal.spanE)
let ?A = "λf. {h ∈ hom_components (q' f). poly_deg h + poly_deg f = poly_deg p}"
let ?B = "λf. {h ∈ hom_components (q' f). poly_deg h + poly_deg f ≠ poly_deg p}"
define F' where "F' = {f ∈ F''. (∑(?A f)) * f ≠ 0}"
define q where "q = (λf. (∑(?A f)) when f ∈ F')"
have "F' ⊆ F''" by (simp add: F'_def)
hence "F' ⊆ F" using ‹F'' ⊆ F› by (rule subset_trans)
have 1: "deg_pm t + poly_deg f = poly_deg p" if "f ∈ F'" and "t ∈ keys (q f)" for f t
proof -
from that have "t ∈ keys (∑(?A f))" by (simp add: q_def)
also have "… ⊆ (⋃h∈?A f. keys h)" by (fact keys_sum_subset)
finally obtain h where "h ∈ ?A f" and "t ∈ keys h" ..
from this(1) have "h ∈ hom_components (q' f)" and eq: "poly_deg h + poly_deg f = poly_deg p"
by simp_all
from this(1) have "homogeneous h" by (rule hom_components_homogeneous)
hence "deg_pm t = poly_deg h" using ‹t ∈ keys h› by (rule homogeneousD_poly_deg)
thus ?thesis by (simp only: eq)
qed
have 2: "deg_pm t = poly_deg p" if "f ∈ F'" and "t ∈ keys (q f * f)" for f t
proof -
from that(1) ‹F' ⊆ F› have "f ∈ F" ..
hence "homogeneous f" by (rule assms(1))
from that(2) obtain s1 s2 where "s1 ∈ keys (q f)" and "s2 ∈ keys f" and t: "t = s1 + s2"
by (rule in_keys_timesE)
from that(1) this(1) have "deg_pm s1 + poly_deg f = poly_deg p" by (rule 1)
moreover from ‹homogeneous f› ‹s2 ∈ keys f› have "deg_pm s2 = poly_deg f"
by (rule homogeneousD_poly_deg)
ultimately show ?thesis by (simp add: t deg_pm_plus)
qed
from ‹F' ⊆ F''› ‹finite F''› have "finite F'" by (rule finite_subset)
thus ?thesis using ‹F' ⊆ F›
proof
note p
also from refl have "(∑f∈F''. q' f * f) = (∑f∈F''. (∑(?A f) * f) + (∑(?B f) * f))"
proof (rule sum.cong)
fix f
assume "f ∈ F''"
from sum_hom_components have "q' f = (∑(hom_components (q' f)))" by (rule sym)
also have "… = (∑(?A f ∪ ?B f))" by (rule arg_cong[where f="sum (λx. x)"]) blast
also have "… = ∑(?A f) + ∑(?B f)"
proof (rule sum.union_disjoint)
have "?A f ⊆ hom_components (q' f)" by blast
thus "finite (?A f)" using finite_hom_components by (rule finite_subset)
next
have "?B f ⊆ hom_components (q' f)" by blast
thus "finite (?B f)" using finite_hom_components by (rule finite_subset)
qed blast
finally show "q' f * f = (∑(?A f) * f) + (∑(?B f) * f)"
by (metis (no_types, lifting) distrib_right)
qed
also have "… = (∑f∈F''. ∑(?A f) * f) + (∑f∈F''. ∑(?B f) * f)" by (rule sum.distrib)
also from ‹finite F''› ‹F' ⊆ F''› have "(∑f∈F''. ∑(?A f) * f) = (∑f∈F'. q f * f)"
proof (intro sum.mono_neutral_cong_right ballI)
fix f
assume "f ∈ F'' - F'"
thus "∑(?A f) * f = 0" by (simp add: F'_def)
next
fix f
assume "f ∈ F'"
thus "∑(?A f) * f = q f * f" by (simp add: q_def)
qed
finally have p[symmetric]: "p = (∑f∈F'. q f * f) + (∑f∈F''. ∑(?B f) * f)" .
moreover have "keys (∑f∈F''. ∑(?B f) * f) = {}"
proof (rule, rule)
fix t
assume t_in: "t ∈ keys (∑f∈F''. ∑(?B f) * f)"
also have "… ⊆ (⋃f∈F''. keys (∑(?B f) * f))" by (fact keys_sum_subset)
finally obtain f where "f ∈ F''" and "t ∈ keys (∑(?B f) * f)" ..
from this(2) obtain s1 s2 where "s1 ∈ keys (∑(?B f))" and "s2 ∈ keys f" and t: "t = s1 + s2"
by (rule in_keys_timesE)
from ‹f ∈ F''› ‹F'' ⊆ F› have "f ∈ F" ..
hence "homogeneous f" by (rule assms(1))
note ‹s1 ∈ keys (∑(?B f))›
also have "keys (∑(?B f)) ⊆ (⋃h∈?B f. keys h)" by (fact keys_sum_subset)
finally obtain h where "h ∈ ?B f" and "s1 ∈ keys h" ..
from this(1) have "h ∈ hom_components (q' f)" and neq: "poly_deg h + poly_deg f ≠ poly_deg p"
by simp_all
from this(1) have "homogeneous h" by (rule hom_components_homogeneous)
hence "deg_pm s1 = poly_deg h" using ‹s1 ∈ keys h› by (rule homogeneousD_poly_deg)
moreover from ‹homogeneous f› ‹s2 ∈ keys f› have "deg_pm s2 = poly_deg f"
by (rule homogeneousD_poly_deg)
ultimately have "deg_pm t ≠ poly_deg p" using neq by (simp add: t deg_pm_plus)
have "t ∉ keys (∑f∈F'. q f * f)"
proof
assume "t ∈ keys (∑f∈F'. q f * f)"
also have "… ⊆ (⋃f∈F'. keys (q f * f))" by (fact keys_sum_subset)
finally obtain f where "f ∈ F'" and "t ∈ keys (q f * f)" ..
hence "deg_pm t = poly_deg p" by (rule 2)
with ‹deg_pm t ≠ poly_deg p› show False ..
qed
with t_in have "t ∈ keys ((∑f∈F'. q f * f) + (∑f∈F''. ∑(?B f) * f))"
by (rule in_keys_plusI2)
hence "t ∈ keys p" by (simp only: p)
with assms(3) have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
with ‹deg_pm t ≠ poly_deg p› show "t ∈ {}" ..
qed (fact empty_subsetI)
ultimately show "p = (∑f∈F'. q f * f)" by simp
next
fix f
show "homogeneous (q f)"
proof (cases "f ∈ F'")
case True
show ?thesis
proof (rule homogeneousI)
fix s t
assume "s ∈ keys (q f)"
with True have *: "deg_pm s + poly_deg f = poly_deg p" by (rule 1)
assume "t ∈ keys (q f)"
with True have "deg_pm t + poly_deg f = poly_deg p" by (rule 1)
with * show "deg_pm s = deg_pm t" by simp
qed
next
case False
thus ?thesis by (simp add: q_def)
qed
assume "f ∈ F'"
show "poly_deg (q f * f) = poly_deg p"
proof (intro antisym)
show "poly_deg (q f * f) ≤ poly_deg p"
proof (rule poly_deg_leI)
fix t
assume "t ∈ keys (q f * f)"
with ‹f ∈ F'› have "deg_pm t = poly_deg p" by (rule 2)
thus "deg_pm t ≤ poly_deg p" by simp
qed
next
from ‹f ∈ F'› have "q f * f ≠ 0" by (simp add: q_def F'_def)
hence "keys (q f * f) ≠ {}" by simp
then obtain t where "t ∈ keys (q f * f)" by blast
with ‹f ∈ F'› have "deg_pm t = poly_deg p" by (rule 2)
moreover from ‹t ∈ keys (q f * f)› have "deg_pm t ≤ poly_deg (q f * f)" by (rule poly_deg_max_keys)
ultimately show "poly_deg p ≤ poly_deg (q f * f)" by simp
qed
qed (simp add: q_def)
qed
corollary homogeneous_idealE:
assumes "⋀f. f ∈ F ⟹ homogeneous f" and "p ∈ ideal F"
obtains F' q where "finite F'" and "F' ⊆ F" and "p = (∑f∈F'. q f * f)"
and "⋀f. poly_deg (q f * f) ≤ poly_deg p" and "⋀f. f ∉ F' ⟹ q f = 0"
proof (cases "p = 0")
case True
show ?thesis
proof
show "p = (∑f∈{}. (λ_. 0) f * f)" by (simp add: True)
qed simp_all
next
case False
define P where "P = (λh qf. finite (fst qf) ∧ fst qf ⊆ F ∧ h = (∑f∈fst qf. snd qf f * f) ∧
(∀f∈fst qf. poly_deg (snd qf f * f) = poly_deg h) ∧ (∀f. f ∉ fst qf ⟶ snd qf f = 0))"
define q0 where "q0 = (λh. SOME qf. P h qf)"
have 1: "P h (q0 h)" if "h ∈ hom_components p" for h
proof -
note assms(1)
moreover from assms that have "h ∈ ideal F" by (rule homogeneous_ideal')
moreover from that have "homogeneous h" by (rule hom_components_homogeneous)
ultimately obtain F' q where "finite F'" and "F' ⊆ F" and "h = (∑f∈F'. q f * f)"
and "⋀f. f ∈ F' ⟹ poly_deg (q f * f) = poly_deg h" and "⋀f. f ∉ F' ⟹ q f = 0"
by (rule homogeneous_idealE_homogeneous) blast+
hence "P h (F', q)" by (simp add: P_def)
thus ?thesis unfolding q0_def by (rule someI)
qed
define F' where "F' = (⋃h∈hom_components p. fst (q0 h))"
define q where "q = (λf. ∑h∈hom_components p. snd (q0 h) f)"
show ?thesis
proof
have "finite F' ∧ F' ⊆ F" unfolding F'_def UN_subset_iff finite_UN[OF finite_hom_components]
proof (intro conjI ballI)
fix h
assume "h ∈ hom_components p"
hence "P h (q0 h)" by (rule 1)
thus "finite (fst (q0 h))" and "fst (q0 h) ⊆ F" by (simp_all only: P_def)
qed
thus "finite F'" and "F' ⊆ F" by simp_all
from sum_hom_components have "p = (∑(hom_components p))" by (rule sym)
also from refl have "… = (∑h∈hom_components p. ∑f∈F'. snd (q0 h) f * f)"
proof (rule sum.cong)
fix h
assume "h ∈ hom_components p"
hence "P h (q0 h)" by (rule 1)
hence "h = (∑f∈fst (q0 h). snd (q0 h) f * f)" and 2: "⋀f. f ∉ fst (q0 h) ⟹ snd (q0 h) f = 0"
by (simp_all add: P_def)
note this(1)
also from ‹finite F'› have "(∑f∈fst (q0 h). (snd (q0 h)) f * f) = (∑f∈F'. snd (q0 h) f * f)"
proof (intro sum.mono_neutral_left ballI)
show "fst (q0 h) ⊆ F'" unfolding F'_def using ‹h ∈ hom_components p› by blast
next
fix f
assume "f ∈ F' - fst (q0 h)"
hence "f ∉ fst (q0 h)" by simp
hence "snd (q0 h) f = 0" by (rule 2)
thus "snd (q0 h) f * f = 0" by simp
qed
finally show "h = (∑f∈F'. snd (q0 h) f * f)" .
qed
also have "… = (∑f∈F'. ∑h∈hom_components p. snd (q0 h) f * f)" by (rule sum.swap)
also have "… = (∑f∈F'. q f * f)" by (simp only: q_def sum_distrib_right)
finally show "p = (∑f∈F'. q f * f)" .
fix f
have "poly_deg (q f * f) = poly_deg (∑h∈hom_components p. snd (q0 h) f * f)"
by (simp only: q_def sum_distrib_right)
also have "… ≤ Max (poly_deg ` (λh. snd (q0 h) f * f) ` hom_components p)"
by (rule poly_deg_sum_le)
also have "… = Max ((λh. poly_deg (snd (q0 h) f * f)) ` hom_components p)"
(is "_ = Max (?f ` _)") by (simp only: image_image)
also have "… ≤ poly_deg p"
proof (rule Max.boundedI)
from finite_hom_components show "finite (?f ` hom_components p)" by (rule finite_imageI)
next
from False show "?f ` hom_components p ≠ {}" by simp
next
fix d
assume "d ∈ ?f ` hom_components p"
then obtain h where "h ∈ hom_components p" and d: "d = ?f h" ..
from this(1) have "P h (q0 h)" by (rule 1)
hence 2: "⋀f. f ∈ fst (q0 h) ⟹ poly_deg (snd (q0 h) f * f) = poly_deg h"
and 3: "⋀f. f ∉ fst (q0 h) ⟹ snd (q0 h) f = 0" by (simp_all add: P_def)
show "d ≤ poly_deg p"
proof (cases "f ∈ fst (q0 h)")
case True
hence "poly_deg (snd (q0 h) f * f) = poly_deg h" by (rule 2)
hence "d = poly_deg h" by (simp only: d)
also from ‹h ∈ hom_components p› have "… ≤ poly_deg p" by (rule poly_deg_hom_components_le)
finally show ?thesis .
next
case False
hence "snd (q0 h) f = 0" by (rule 3)
thus ?thesis by (simp add: d)
qed
qed
finally show "poly_deg (q f * f) ≤ poly_deg p" .
assume "f ∉ F'"
show "q f = 0" unfolding q_def
proof (intro sum.neutral ballI)
fix h
assume "h ∈ hom_components p"
hence "P h (q0 h)" by (rule 1)
hence 2: "⋀f. f ∉ fst (q0 h) ⟹ snd (q0 h) f = 0" by (simp add: P_def)
show "snd (q0 h) f = 0"
proof (intro 2 notI)
assume "f ∈ fst (q0 h)"
hence "f ∈ F'" unfolding F'_def using ‹h ∈ hom_components p› by blast
with ‹f ∉ F'› show False ..
qed
qed
qed
qed
corollary homogeneous_idealE_finite:
assumes "finite F" and "⋀f. f ∈ F ⟹ homogeneous f" and "p ∈ ideal F"
obtains q where "p = (∑f∈F. q f * f)" and "⋀f. poly_deg (q f * f) ≤ poly_deg p"
and "⋀f. f ∉ F ⟹ q f = 0"
proof -
from assms(2, 3) obtain F' q where "F' ⊆ F" and p: "p = (∑f∈F'. q f * f)"
and "⋀f. poly_deg (q f * f) ≤ poly_deg p" and 1: "⋀f. f ∉ F' ⟹ q f = 0"
by (rule homogeneous_idealE) blast+
show ?thesis
proof
from assms(1) ‹F' ⊆ F› have "(∑f∈F'. q f * f) = (∑f∈F. q f * f)"
proof (intro sum.mono_neutral_left ballI)
fix f
assume "f ∈ F - F'"
hence "f ∉ F'" by simp
hence "q f = 0" by (rule 1)
thus "q f * f = 0" by simp
qed
thus "p = (∑f∈F. q f * f)" by (simp only: p)
next
fix f
show "poly_deg (q f * f) ≤ poly_deg p" by fact
assume "f ∉ F"
with ‹F' ⊆ F› have "f ∉ F'" by blast
thus "q f = 0" by (rule 1)
qed
qed
subsubsection ‹Homogenization and Dehomogenization›
definition homogenize :: "'x ⇒ (('x ⇒⇩0 nat) ⇒⇩0 'a) ⇒ (('x ⇒⇩0 nat) ⇒⇩0 'a::semiring_1)"
where "homogenize x p = (∑t∈keys p. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
definition dehomo_subst :: "'x ⇒ 'x ⇒ (('x ⇒⇩0 nat) ⇒⇩0 'a::zero_neq_one)"
where "dehomo_subst x = (λy. if y = x then 1 else monomial 1 (Poly_Mapping.single y 1))"
definition dehomogenize :: "'x ⇒ (('x ⇒⇩0 nat) ⇒⇩0 'a) ⇒ (('x ⇒⇩0 nat) ⇒⇩0 'a::comm_semiring_1)"
where "dehomogenize x = poly_subst (dehomo_subst x)"
lemma homogenize_zero [simp]: "homogenize x 0 = 0"
by (simp add: homogenize_def)
lemma homogenize_uminus [simp]: "homogenize x (- p) = - homogenize x (p::_ ⇒⇩0 'a::ring_1)"
by (simp add: homogenize_def keys_uminus sum.reindex inj_on_def single_uminus sum_negf)
lemma homogenize_monom_mult [simp]:
"homogenize x (punit.monom_mult c t p) = punit.monom_mult c t (homogenize x p)"
for c::"'a::{semiring_1,semiring_no_zero_divisors_cancel}"
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
show ?thesis
proof (cases "c = 0")
case True
thus ?thesis by simp
next
case False
show ?thesis
by (simp add: homogenize_def punit.keys_monom_mult ‹p ≠ 0› False sum.reindex
punit.lookup_monom_mult punit.monom_mult_sum_right poly_deg_monom_mult
punit.monom_mult_monomial ac_simps deg_pm_plus)
qed
qed
lemma homogenize_alt:
"homogenize x p = (∑q∈hom_components p. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)"
proof -
have "homogenize x p = (∑t∈Keys (hom_components p). monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
by (simp only: homogenize_def Keys_hom_components)
also have "… = (∑t∈(⋃ (keys ` hom_components p)). monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
by (simp only: Keys_def)
also have "… = (∑q∈hom_components p. (∑t∈keys q. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)))"
by (auto intro!: sum.UNION_disjoint finite_hom_components finite_keys dest: hom_components_keys_disjoint)
also have "… = (∑q∈hom_components p. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)"
using refl
proof (rule sum.cong)
fix q
assume q: "q ∈ hom_components p"
hence "homogeneous q" by (rule hom_components_homogeneous)
have "(∑t∈keys q. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)) =
(∑t∈keys q. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) (monomial (lookup q t) t))"
using refl
proof (rule sum.cong)
fix t
assume "t ∈ keys q"
with ‹homogeneous q› have "deg_pm t = poly_deg q" by (rule homogeneousD_poly_deg)
moreover from q ‹t ∈ keys q› have "lookup q t = lookup p t" by (rule lookup_hom_components)
ultimately show "monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t) =
punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) (monomial (lookup q t) t)"
by (simp add: punit.monom_mult_monomial)
qed
also have "… = punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q"
by (simp only: poly_mapping_sum_monomials flip: punit.monom_mult_sum_right)
finally show "(∑t∈keys q. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)) =
punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q" .
qed
finally show ?thesis .
qed
lemma keys_homogenizeE:
assumes "t ∈ keys (homogenize x p)"
obtains t' where "t' ∈ keys p" and "t = Poly_Mapping.single x (poly_deg p - deg_pm t') + t'"
proof -
note assms
also have "keys (homogenize x p) ⊆
(⋃t∈keys p. keys (monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)))"
unfolding homogenize_def by (rule keys_sum_subset)
finally obtain t' where "t' ∈ keys p"
and "t ∈ keys (monomial (lookup p t') (Poly_Mapping.single x (poly_deg p - deg_pm t') + t'))" ..
from this(2) have "t = Poly_Mapping.single x (poly_deg p - deg_pm t') + t'"
by (simp split: if_split_asm)
with ‹t' ∈ keys p› show ?thesis ..
qed
lemma keys_homogenizeE_alt:
assumes "t ∈ keys (homogenize x p)"
obtains q t' where "q ∈ hom_components p" and "t' ∈ keys q"
and "t = Poly_Mapping.single x (poly_deg p - poly_deg q) + t'"
proof -
note assms
also have "keys (homogenize x p) ⊆
(⋃q∈hom_components p. keys (punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q))"
unfolding homogenize_alt by (rule keys_sum_subset)
finally obtain q where q: "q ∈ hom_components p"
and "t ∈ keys (punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)" ..
note this(2)
also have "… ⊆ (+) (Poly_Mapping.single x (poly_deg p - poly_deg q)) ` keys q"
by (rule punit.keys_monom_mult_subset[simplified])
finally obtain t' where "t' ∈ keys q" and "t = Poly_Mapping.single x (poly_deg p - poly_deg q) + t'" ..
with q show ?thesis ..
qed
lemma deg_pm_homogenize:
assumes "t ∈ keys (homogenize x p)"
shows "deg_pm t = poly_deg p"
proof -
from assms obtain q t' where q: "q ∈ hom_components p" and "t' ∈ keys q"
and t: "t = Poly_Mapping.single x (poly_deg p - poly_deg q) + t'" by (rule keys_homogenizeE_alt)
from q have "homogeneous q" by (rule hom_components_homogeneous)
hence "deg_pm t' = poly_deg q" using ‹t' ∈ keys q› by (rule homogeneousD_poly_deg)
moreover from q have "poly_deg q ≤ poly_deg p" by (rule poly_deg_hom_components_le)
ultimately show ?thesis by (simp add: t deg_pm_plus deg_pm_single)
qed
corollary homogeneous_homogenize: "homogeneous (homogenize x p)"
proof (rule homogeneousI)
fix s t
assume "s ∈ keys (homogenize x p)"
hence *: "deg_pm s = poly_deg p" by (rule deg_pm_homogenize)
assume "t ∈ keys (homogenize x p)"
hence "deg_pm t = poly_deg p" by (rule deg_pm_homogenize)
with * show "deg_pm s = deg_pm t" by simp
qed
corollary poly_deg_homogenize_le: "poly_deg (homogenize x p) ≤ poly_deg p"
proof (rule poly_deg_leI)
fix t
assume "t ∈ keys (homogenize x p)"
hence "deg_pm t = poly_deg p" by (rule deg_pm_homogenize)
thus "deg_pm t ≤ poly_deg p" by simp
qed
lemma homogenize_id_iff [simp]: "homogenize x p = p ⟷ homogeneous p"
proof
assume "homogenize x p = p"
moreover have "homogeneous (homogenize x p)" by (fact homogeneous_homogenize)
ultimately show "homogeneous p" by simp
next
assume "homogeneous p"
hence "hom_components p = (if p = 0 then {} else {p})" by (rule hom_components_of_homogeneous)
thus "homogenize x p = p" by (simp add: homogenize_alt split: if_split_asm)
qed
lemma homogenize_homogenize [simp]: "homogenize x (homogenize x p) = homogenize x p"
by (simp add: homogeneous_homogenize)
lemma homogenize_monomial: "homogenize x (monomial c t) = monomial c t"
by (simp only: homogenize_id_iff homogeneous_monomial)
lemma indets_homogenize_subset: "indets (homogenize x p) ⊆ insert x (indets p)"
proof
fix y
assume "y ∈ indets (homogenize x p)"
then obtain t where "t ∈ keys (homogenize x p)" and "y ∈ keys t" by (rule in_indetsE)
from this(1) obtain t' where "t' ∈ keys p"
and t: "t = Poly_Mapping.single x (poly_deg p - deg_pm t') + t'" by (rule keys_homogenizeE)
note ‹y ∈ keys t›
also have "keys t ⊆ keys (Poly_Mapping.single x (poly_deg p - deg_pm t')) ∪ keys t'"
unfolding t by (rule Poly_Mapping.keys_add)
finally show "y ∈ insert x (indets p)"
proof
assume "y ∈ keys (Poly_Mapping.single x (poly_deg p - deg_pm t'))"
thus ?thesis by (simp split: if_split_asm)
next
assume "y ∈ keys t'"
hence "y ∈ indets p" using ‹t' ∈ keys p› by (rule in_indetsI)
thus ?thesis by simp
qed
qed
lemma homogenize_in_Polys: "p ∈ P[X] ⟹ homogenize x p ∈ P[insert x X]"
using indets_homogenize_subset[of x p] by (auto simp: Polys_alt)
lemma lookup_homogenize:
assumes "x ∉ indets p" and "x ∉ keys t"
shows "lookup (homogenize x p) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t) = lookup p t"
proof -
let ?p = "homogenize x p"
let ?t = "Poly_Mapping.single x (poly_deg p - deg_pm t) + t"
have eq: "(∑s∈keys p - {t}. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t) = 0"
proof (intro sum.neutral ballI)
fix s
assume "s ∈ keys p - {t}"
hence "s ∈ keys p" and "s ≠ t" by simp_all
from this(1) have "keys s ⊆ indets p" by (simp add: in_indetsI subsetI)
with assms(1) have "x ∉ keys s" by blast
have "?t ≠ Poly_Mapping.single x (poly_deg p - deg_pm s) + s"
proof
assume a: "?t = Poly_Mapping.single x (poly_deg p - deg_pm s) + s"
hence "lookup ?t x = lookup (Poly_Mapping.single x (poly_deg p - deg_pm s) + s) x"
by simp
moreover from assms(2) have "lookup t x = 0" by (simp add: in_keys_iff)
moreover from ‹x ∉ keys s› have "lookup s x = 0" by (simp add: in_keys_iff)
ultimately have "poly_deg p - deg_pm t = poly_deg p - deg_pm s" by (simp add: lookup_add)
with a have "s = t" by simp
with ‹s ≠ t› show False ..
qed
thus "lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t = 0"
by (simp add: lookup_single)
qed
show ?thesis
proof (cases "t ∈ keys p")
case True
have "lookup ?p ?t = (∑s∈keys p. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t)"
by (simp add: homogenize_def lookup_sum)
also have "… = lookup (monomial (lookup p t) ?t) ?t +
(∑s∈keys p - {t}. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t)"
using finite_keys True by (rule sum.remove)
also have "… = lookup p t" by (simp add: eq)
finally show ?thesis .
next
case False
hence 1: "keys p - {t} = keys p" by simp
have "lookup ?p ?t = (∑s∈keys p - {t}. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t)"
by (simp add: homogenize_def lookup_sum 1)
also have "… = 0" by (simp only: eq)
also from False have "… = lookup p t" by (simp add: in_keys_iff)
finally show ?thesis .
qed
qed
lemma keys_homogenizeI:
assumes "x ∉ indets p" and "t ∈ keys p"
shows "Poly_Mapping.single x (poly_deg p - deg_pm t) + t ∈ keys (homogenize x p)" (is "?t ∈ keys ?p")
proof -
from assms(2) have "keys t ⊆ indets p" by (simp add: in_indetsI subsetI)
with assms(1) have "x ∉ keys t" by blast
with assms(1) have "lookup ?p ?t = lookup p t" by (rule lookup_homogenize)
also from assms(2) have "… ≠ 0" by (simp add: in_keys_iff)
finally show ?thesis by (simp add: in_keys_iff)
qed
lemma keys_homogenize:
"x ∉ indets p ⟹ keys (homogenize x p) = (λt. Poly_Mapping.single x (poly_deg p - deg_pm t) + t) ` keys p"
by (auto intro: keys_homogenizeI elim: keys_homogenizeE)
lemma card_keys_homogenize:
assumes "x ∉ indets p"
shows "card (keys (homogenize x p)) = card (keys p)"
unfolding keys_homogenize[OF assms]
proof (intro card_image inj_onI)
fix s t
assume "s ∈ keys p" and "t ∈ keys p"
with assms have "x ∉ keys s" and "x ∉ keys t" by (auto dest: in_indetsI simp only:)
let ?s = "Poly_Mapping.single x (poly_deg p - deg_pm s)"
let ?t = "Poly_Mapping.single x (poly_deg p - deg_pm t)"
assume "?s + s = ?t + t"
hence "lookup (?s + s) x = lookup (?t + t) x" by simp
with ‹x ∉ keys s› ‹x ∉ keys t› have "?s = ?t" by (simp add: lookup_add in_keys_iff)
with ‹?s + s = ?t + t› show "s = t" by simp
qed
lemma poly_deg_homogenize:
assumes "x ∉ indets p"
shows "poly_deg (homogenize x p) = poly_deg p"
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
then obtain t where "t ∈ keys p" and 1: "poly_deg p = deg_pm t" by (rule poly_degE)
from assms this(1) have "Poly_Mapping.single x (poly_deg p - deg_pm t) + t ∈ keys (homogenize x p)"
by (rule keys_homogenizeI)
hence "t ∈ keys (homogenize x p)" by (simp add: 1)
hence "poly_deg p ≤ poly_deg (homogenize x p)" unfolding 1 by (rule poly_deg_max_keys)
with poly_deg_homogenize_le show ?thesis by (rule antisym)
qed
lemma maxdeg_homogenize:
assumes "x ∉ ⋃ (indets ` F)"
shows "maxdeg (homogenize x ` F) = maxdeg F"
unfolding maxdeg_def image_image
proof (rule arg_cong[where f=Max], rule set_eqI)
fix d
show "d ∈ (λf. poly_deg (homogenize x f)) ` F ⟷ d ∈ poly_deg ` F"
proof
assume "d ∈ (λf. poly_deg (homogenize x f)) ` F"
then obtain f where "f ∈ F" and d: "d = poly_deg (homogenize x f)" ..
from assms this(1) have "x ∉ indets f" by blast
hence "d = poly_deg f" by (simp add: d poly_deg_homogenize)
with ‹f ∈ F› show "d ∈ poly_deg ` F" by (rule rev_image_eqI)
next
assume "d ∈ poly_deg ` F"
then obtain f where "f ∈ F" and d: "d = poly_deg f" ..
from assms this(1) have "x ∉ indets f" by blast
hence "d = poly_deg (homogenize x f)" by (simp add: d poly_deg_homogenize)
with ‹f ∈ F› show "d ∈ (λf. poly_deg (homogenize x f)) ` F" by (rule rev_image_eqI)
qed
qed
lemma homogeneous_ideal_homogenize:
assumes "⋀f. f ∈ F ⟹ homogeneous f" and "p ∈ ideal F"
shows "homogenize x p ∈ ideal F"
proof -
have "homogenize x p = (∑q∈hom_components p. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)"
by (fact homogenize_alt)
also have "… ∈ ideal F"
proof (rule ideal.span_sum)
fix q
assume "q ∈ hom_components p"
with assms have "q ∈ ideal F" by (rule homogeneous_ideal')
thus "punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q ∈ ideal F"
by (rule punit.pmdl_closed_monom_mult[simplified])
qed
finally show ?thesis .
qed
lemma subst_pp_dehomo_subst [simp]:
"subst_pp (dehomo_subst x) t = monomial (1::'b::comm_semiring_1) (except t {x})"
proof -
have "subst_pp (dehomo_subst x) t = ((∏y∈keys t. dehomo_subst x y ^ lookup t y)::_ ⇒⇩0 'b)"
by (fact subst_pp_def)
also have "… = (∏y∈keys t - {y0. dehomo_subst x y0 ^ lookup t y0 = (1::_ ⇒⇩0 'b)}. dehomo_subst x y ^ lookup t y)"
by (rule sym, rule prod.setdiff_irrelevant, fact finite_keys)
also have "… = (∏y∈keys t - {x}. monomial 1 (Poly_Mapping.single y 1) ^ lookup t y)"
proof (rule prod.cong)
have "dehomo_subst x x ^ lookup t x = 1" by (simp add: dehomo_subst_def)
moreover {
fix y
assume "y ≠ x"
hence "dehomo_subst x y ^ lookup t y = monomial 1 (Poly_Mapping.single y (lookup t y))"
by (simp add: dehomo_subst_def monomial_single_power)
moreover assume "dehomo_subst x y ^ lookup t y = 1"
ultimately have "Poly_Mapping.single y (lookup t y) = 0"
by (smt single_one monomial_inj zero_neq_one)
hence "lookup t y = 0" by (rule monomial_0D)
moreover assume "y ∈ keys t"
ultimately have False by (simp add: in_keys_iff)
}
ultimately show "keys t - {y0. dehomo_subst x y0 ^ lookup t y0 = 1} = keys t - {x}" by auto
qed (simp add: dehomo_subst_def)
also have "… = (∏y∈keys t - {x}. monomial 1 (Poly_Mapping.single y (lookup t y)))"
by (simp add: monomial_single_power)
also have "… = monomial 1 (∑y∈keys t - {x}. Poly_Mapping.single y (lookup t y))"
by (simp flip: punit.monomial_prod_sum)
also have "(∑y∈keys t - {x}. Poly_Mapping.single y (lookup t y)) = except t {x}"
proof (rule poly_mapping_eqI, simp add: lookup_sum lookup_except lookup_single, rule)
fix y
assume "y ≠ x"
show "(∑z∈keys t - {x}. lookup t z when z = y) = lookup t y"
proof (cases "y ∈ keys t")
case True
have "finite (keys t - {x})" by simp
moreover from True ‹y ≠ x› have "y ∈ keys t - {x}" by simp
ultimately have "(∑z∈keys t - {x}. lookup t z when z = y) =
(lookup t y when y = y) + (∑z∈keys t - {x} - {y}. lookup t z when z = y)"
by (rule sum.remove)
also have "(∑z∈keys t - {x} - {y}. lookup t z when z = y) = 0" by auto
finally show ?thesis by simp
next
case False
hence "(∑z∈keys t - {x}. lookup t z when z = y) = 0" by (auto simp: when_def)
also from False have "… = lookup t y" by (simp add: in_keys_iff)
finally show ?thesis .
qed
qed
finally show ?thesis .
qed
lemma
shows dehomogenize_zero [simp]: "dehomogenize x 0 = 0"
and dehomogenize_one [simp]: "dehomogenize x 1 = 1"
and dehomogenize_monomial: "dehomogenize x (monomial c t) = monomial c (except t {x})"
and dehomogenize_plus: "dehomogenize x (p + q) = dehomogenize x p + dehomogenize x q"
and dehomogenize_uminus: "dehomogenize x (- r) = - dehomogenize x (r::_ ⇒⇩0 _::comm_ring_1)"
and dehomogenize_minus: "dehomogenize x (r - r') = dehomogenize x r - dehomogenize x r'"
and dehomogenize_times: "dehomogenize x (p * q) = dehomogenize x p * dehomogenize x q"
and dehomogenize_power: "dehomogenize x (p ^ n) = dehomogenize x p ^ n"
and dehomogenize_sum: "dehomogenize x (sum f A) = (∑a∈A. dehomogenize x (f a))"
and dehomogenize_prod: "dehomogenize x (prod f A) = (∏a∈A. dehomogenize x (f a))"
by (simp_all add: dehomogenize_def poly_subst_monomial poly_subst_plus poly_subst_uminus
poly_subst_minus poly_subst_times poly_subst_power poly_subst_sum poly_subst_prod punit.monom_mult_monomial)
corollary dehomogenize_monom_mult:
"dehomogenize x (punit.monom_mult c t p) = punit.monom_mult c (except t {x}) (dehomogenize x p)"
by (simp only: times_monomial_left[symmetric] dehomogenize_times dehomogenize_monomial)
lemma poly_deg_dehomogenize_le: "poly_deg (dehomogenize x p) ≤ poly_deg p"
unfolding dehomogenize_def dehomo_subst_def
by (rule poly_deg_poly_subst_le) (simp add: poly_deg_monomial deg_pm_single)
lemma indets_dehomogenize: "indets (dehomogenize x p) ⊆ indets p - {x}"
for p::"('x ⇒⇩0 nat) ⇒⇩0 'a::comm_semiring_1"
proof
fix y::'x
assume "y ∈ indets (dehomogenize x p)"
then obtain y' where "y' ∈ indets p" and "y ∈ indets ((dehomo_subst x y')::_ ⇒⇩0 'a)"
unfolding dehomogenize_def by (rule in_indets_poly_substE)
from this(2) have "y = y'" and "y' ≠ x"
by (simp_all add: dehomo_subst_def indets_monomial split: if_split_asm)
with ‹y' ∈ indets p› show "y ∈ indets p - {x}" by simp
qed
lemma dehomogenize_id_iff [simp]: "dehomogenize x p = p ⟷ x ∉ indets p"
proof
assume eq: "dehomogenize x p = p"
from indets_dehomogenize[of x p] show "x ∉ indets p" by (auto simp: eq)
next
assume a: "x ∉ indets p"
show "dehomogenize x p = p" unfolding dehomogenize_def
proof (rule poly_subst_id)
fix y
assume "y ∈ indets p"
with a have "y ≠ x" by blast
thus "dehomo_subst x y = monomial 1 (Poly_Mapping.single y 1)" by (simp add: dehomo_subst_def)
qed
qed
lemma dehomogenize_dehomogenize [simp]: "dehomogenize x (dehomogenize x p) = dehomogenize x p"
proof -
from indets_dehomogenize[of x p] have "x ∉ indets (dehomogenize x p)" by blast
thus ?thesis by simp
qed
lemma dehomogenize_homogenize [simp]: "dehomogenize x (homogenize x p) = dehomogenize x p"
proof -
have "dehomogenize x (homogenize x p) = sum (dehomogenize x) (hom_components p)"
by (simp add: homogenize_alt dehomogenize_sum dehomogenize_monom_mult except_single)
also have "… = dehomogenize x p" by (simp only: sum_hom_components flip: dehomogenize_sum)
finally show ?thesis .
qed
corollary dehomogenize_homogenize_id: "x ∉ indets p ⟹ dehomogenize x (homogenize x p) = p"
by simp
lemma range_dehomogenize: "range (dehomogenize x) = (P[- {x}] :: (_ ⇒⇩0 'a::comm_semiring_1) set)"
proof (intro subset_antisym subsetI PolysI_alt range_eqI)
fix p::"_ ⇒⇩0 'a" and y
assume "p ∈ range (dehomogenize x)"
then obtain q where p: "p = dehomogenize x q" ..
assume "y ∈ indets p"
hence "y ∈ indets (dehomogenize x q)" by (simp only: p)
with indets_dehomogenize have "y ∈ indets q - {x}" ..
thus "y ∈ - {x}" by simp
next
fix p::"_ ⇒⇩0 'a"
assume "p ∈ P[- {x}]"
hence "x ∉ indets p" by (auto dest: PolysD)
thus "p = dehomogenize x (homogenize x p)" by (rule dehomogenize_homogenize_id[symmetric])
qed
lemma dehomogenize_alt: "dehomogenize x p = (∑t∈keys p. monomial (lookup p t) (except t {x}))"
proof -
have "dehomogenize x p = dehomogenize x (∑t∈keys p. monomial (lookup p t) t)"
by (simp only: poly_mapping_sum_monomials)
also have "… = (∑t∈keys p. monomial (lookup p t) (except t {x}))"
by (simp only: dehomogenize_sum dehomogenize_monomial)
finally show ?thesis .
qed
lemma keys_dehomogenizeE:
assumes "t ∈ keys (dehomogenize x p)"
obtains s where "s ∈ keys p" and "t = except s {x}"
proof -
note assms
also have "keys (dehomogenize x p) ⊆ (⋃s∈keys p. keys (monomial (lookup p s) (except s {x})))"
unfolding dehomogenize_alt by (rule keys_sum_subset)
finally obtain s where "s ∈ keys p" and "t ∈ keys (monomial (lookup p s) (except s {x}))" ..
from this(2) have "t = except s {x}" by (simp split: if_split_asm)
with ‹s ∈ keys p› show ?thesis ..
qed
lemma except_inj_on_keys_homogeneous:
assumes "homogeneous p"
shows "inj_on (λt. except t {x}) (keys p)"
proof
fix s t
assume "s ∈ keys p" and "t ∈ keys p"
from assms this(1) have "deg_pm s = poly_deg p" by (rule homogeneousD_poly_deg)
moreover from assms ‹t ∈ keys p› have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
ultimately have "deg_pm (Poly_Mapping.single x (lookup s x) + except s {x}) =
deg_pm (Poly_Mapping.single x (lookup t x) + except t {x})"
by (simp only: flip: plus_except)
moreover assume 1: "except s {x} = except t {x}"
ultimately have 2: "lookup s x = lookup t x"
by (simp only: deg_pm_plus deg_pm_single)
show "s = t"
proof (rule poly_mapping_eqI)
fix y
show "lookup s y = lookup t y"
proof (cases "y = x")
case True
with 2 show ?thesis by simp
next
case False
hence "lookup s y = lookup (except s {x}) y" and "lookup t y = lookup (except t {x}) y"
by (simp_all add: lookup_except)
with 1 show ?thesis by simp
qed
qed
qed
lemma lookup_dehomogenize:
assumes "homogeneous p" and "t ∈ keys p"
shows "lookup (dehomogenize x p) (except t {x}) = lookup p t"
proof -
let ?t = "except t {x}"
have eq: "(∑s∈keys p - {t}. lookup (monomial (lookup p s) (except s {x})) ?t) = 0"
proof (intro sum.neutral ballI)
fix s
assume "s ∈ keys p - {t}"
hence "s ∈ keys p" and "s ≠ t" by simp_all
have "?t ≠ except s {x}"
proof
from assms(1) have "inj_on (λt. except t {x}) (keys p)" by (rule except_inj_on_keys_homogeneous)
moreover assume "?t = except s {x}"
ultimately have "t = s" using assms(2) ‹s ∈ keys p› by (rule inj_onD)
with ‹s ≠ t› show False by simp
qed
thus "lookup (monomial (lookup p s) (except s {x})) ?t = 0" by (simp add: lookup_single)
qed
have "lookup (dehomogenize x p) ?t = (∑s∈keys p. lookup (monomial (lookup p s) (except s {x})) ?t)"
by (simp only: dehomogenize_alt lookup_sum)
also have "… = lookup (monomial (lookup p t) ?t) ?t +
(∑s∈keys p - {t}. lookup (monomial (lookup p s) (except s {x})) ?t)"
using finite_keys assms(2) by (rule sum.remove)
also have "… = lookup p t" by (simp add: eq)
finally show ?thesis .
qed
lemma keys_dehomogenizeI:
assumes "homogeneous p" and "t ∈ keys p"
shows "except t {x} ∈ keys (dehomogenize x p)"
proof -
from assms have "lookup (dehomogenize x p) (except t {x}) = lookup p t" by (rule lookup_dehomogenize)
also from assms(2) have "… ≠ 0" by (simp add: in_keys_iff)
finally show ?thesis by (simp add: in_keys_iff)
qed
lemma homogeneous_homogenize_dehomogenize:
assumes "homogeneous p"
obtains d where "d = poly_deg p - poly_deg (homogenize x (dehomogenize x p))"
and "punit.monom_mult 1 (Poly_Mapping.single x d) (homogenize x (dehomogenize x p)) = p"
proof (cases "p = 0")
case True
hence "0 = poly_deg p - poly_deg (homogenize x (dehomogenize x p))"
and "punit.monom_mult 1 (Poly_Mapping.single x 0) (homogenize x (dehomogenize x p)) = p"
by simp_all
thus ?thesis ..
next
case False
let ?q = "dehomogenize x p"
let ?p = "homogenize x ?q"
define d where "d = poly_deg p - poly_deg ?p"
show ?thesis
proof
have "punit.monom_mult 1 (Poly_Mapping.single x d) ?p =
(∑t∈keys ?q. monomial (lookup ?q t) (Poly_Mapping.single x (d + (poly_deg ?q - deg_pm t)) + t))"
by (simp add: homogenize_def punit.monom_mult_sum_right punit.monom_mult_monomial flip: add.assoc single_add)
also have "… = (∑t∈keys ?q. monomial (lookup ?q t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
using refl
proof (rule sum.cong)
fix t
assume "t ∈ keys ?q"
have "poly_deg ?p = poly_deg ?q"
proof (rule poly_deg_homogenize)
from indets_dehomogenize show "x ∉ indets ?q" by fastforce
qed
hence d: "d = poly_deg p - poly_deg ?q" by (simp only: d_def)
thm poly_deg_dehomogenize_le
from ‹t ∈ keys ?q› have "d + (poly_deg ?q - deg_pm t) = (d + poly_deg ?q) - deg_pm t"
by (intro add_diff_assoc poly_deg_max_keys)
also have "d + poly_deg ?q = poly_deg p" by (simp add: d poly_deg_dehomogenize_le)
finally show "monomial (lookup ?q t) (Poly_Mapping.single x (d + (poly_deg ?q - deg_pm t)) + t) =
monomial (lookup ?q t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)"
by (simp only:)
qed
also have "… = (∑t∈(λs. except s {x}) ` keys p.
monomial (lookup ?q t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
proof (rule sum.mono_neutral_left)
show "keys (dehomogenize x p) ⊆ (λs. except s {x}) ` keys p"
proof
fix t
assume "t ∈ keys (dehomogenize x p)"
then obtain s where "s ∈ keys p" and "t = except s {x}" by (rule keys_dehomogenizeE)
thus "t ∈ (λs. except s {x}) ` keys p" by (rule rev_image_eqI)
qed
qed (simp_all add: in_keys_iff)
also from assms have "… = (∑t∈keys p. monomial (lookup ?q (except t {x}))
(Poly_Mapping.single x (poly_deg p - deg_pm (except t {x})) + except t {x}))"
by (intro sum.reindex[unfolded comp_def] except_inj_on_keys_homogeneous)
also from refl have "… = (∑t∈keys p. monomial (lookup p t) t)"
proof (rule sum.cong)
fix t
assume "t ∈ keys p"
with assms have "lookup ?q (except t {x}) = lookup p t" by (rule lookup_dehomogenize)
moreover have "Poly_Mapping.single x (poly_deg p - deg_pm (except t {x})) + except t {x} = t"
(is "?l = _")
proof (rule poly_mapping_eqI)
fix y
show "lookup ?l y = lookup t y"
proof (cases "y = x")
case True
from assms ‹t ∈ keys p› have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
also have "deg_pm t = deg_pm (Poly_Mapping.single x (lookup t x) + except t {x})"
by (simp flip: plus_except)
also have "… = lookup t x + deg_pm (except t {x})" by (simp only: deg_pm_plus deg_pm_single)
finally have "poly_deg p - deg_pm (except t {x}) = lookup t x" by simp
thus ?thesis by (simp add: True lookup_add lookup_except lookup_single)
next
case False
thus ?thesis by (simp add: lookup_add lookup_except lookup_single)
qed
qed
ultimately show "monomial (lookup ?q (except t {x}))
(Poly_Mapping.single x (poly_deg p - deg_pm (except t {x})) + except t {x}) =
monomial (lookup p t) t" by (simp only:)
qed
also have "… = p" by (fact poly_mapping_sum_monomials)
finally show "punit.monom_mult 1 (Poly_Mapping.single x d) ?p = p" .
qed (simp only: d_def)
qed
lemma dehomogenize_zeroD:
assumes "dehomogenize x p = 0" and "homogeneous p"
shows "p = 0"
proof -
from assms(2) obtain d
where "punit.monom_mult 1 (Poly_Mapping.single x d) (homogenize x (dehomogenize x p)) = p"
by (rule homogeneous_homogenize_dehomogenize)
thus ?thesis by (simp add: assms(1))
qed
lemma dehomogenize_ideal: "dehomogenize x ` ideal F = ideal (dehomogenize x ` F) ∩ P[- {x}]"
unfolding range_dehomogenize[symmetric]
using dehomogenize_plus dehomogenize_times dehomogenize_dehomogenize by (rule image_ideal_eq_Int)
corollary dehomogenize_ideal_subset: "dehomogenize x ` ideal F ⊆ ideal (dehomogenize x ` F)"
by (simp add: dehomogenize_ideal)
lemma ideal_dehomogenize:
assumes "ideal G = ideal (homogenize x ` F)" and "F ⊆ P[UNIV - {x}]"
shows "ideal (dehomogenize x ` G) = ideal F"
proof -
have eq: "dehomogenize x (homogenize x f) = f" if "f ∈ F" for f
proof (rule dehomogenize_homogenize_id)
from that assms(2) have "f ∈ P[UNIV - {x}]" ..
thus "x ∉ indets f" by (auto simp: Polys_alt)
qed
show ?thesis
proof (intro Set.equalityI ideal.span_subset_spanI)
show "dehomogenize x ` G ⊆ ideal F"
proof
fix q
assume "q ∈ dehomogenize x ` G"
then obtain g where "g ∈ G" and q: "q = dehomogenize x g" ..
from this(1) have "g ∈ ideal G" by (rule ideal.span_base)
also have "… = ideal (homogenize x ` F)" by fact
finally have "q ∈ dehomogenize x ` ideal (homogenize x ` F)" using q by (rule rev_image_eqI)
also have "… ⊆ ideal (dehomogenize x ` homogenize x ` F)" by (rule dehomogenize_ideal_subset)
also have "dehomogenize x ` homogenize x ` F = F"
by (auto simp: eq image_image simp del: dehomogenize_homogenize intro!: image_eqI)
finally show "q ∈ ideal F" .
qed
next
show "F ⊆ ideal (dehomogenize x ` G)"
proof
fix f
assume "f ∈ F"
hence "homogenize x f ∈ homogenize x ` F" by (rule imageI)
also have "… ⊆ ideal (homogenize x ` F)" by (rule ideal.span_superset)
also from assms(1) have "… = ideal G" by (rule sym)
finally have "dehomogenize x (homogenize x f) ∈ dehomogenize x ` ideal G" by (rule imageI)
with ‹f ∈ F› have "f ∈ dehomogenize x ` ideal G" by (simp only: eq)
also have "… ⊆ ideal (dehomogenize x ` G)" by (rule dehomogenize_ideal_subset)
finally show "f ∈ ideal (dehomogenize x ` G)" .
qed
qed
qed
subsection ‹Embedding Polynomial Rings in Larger Polynomial Rings (With One Additional Indeterminate)›
text ‹We define a homomorphism for embedding a polynomial ring in a larger polynomial ring, and its
inverse. This is mainly needed for homogenizing wrt. a fresh indeterminate.›
definition extend_indets_subst :: "'x ⇒ ('x option ⇒⇩0 nat) ⇒⇩0 'a::comm_semiring_1"
where "extend_indets_subst x = monomial 1 (Poly_Mapping.single (Some x) 1)"
definition extend_indets :: "(('x ⇒⇩0 nat) ⇒⇩0 'a) ⇒ ('x option ⇒⇩0 nat) ⇒⇩0 'a::comm_semiring_1"
where "extend_indets = poly_subst extend_indets_subst"
definition restrict_indets_subst :: "'x option ⇒ 'x ⇒⇩0 nat"
where "restrict_indets_subst x = (case x of Some y ⇒ Poly_Mapping.single y 1 | _ ⇒ 0)"
definition restrict_indets :: "(('x option ⇒⇩0 nat) ⇒⇩0 'a) ⇒ ('x ⇒⇩0 nat) ⇒⇩0 'a::comm_semiring_1"
where "restrict_indets = poly_subst (λx. monomial 1 (restrict_indets_subst x))"
definition restrict_indets_pp :: "('x option ⇒⇩0 nat) ⇒ ('x ⇒⇩0 nat)"
where "restrict_indets_pp t = (∑x∈keys t. lookup t x ⋅ restrict_indets_subst x)"
lemma lookup_extend_indets_subst_aux:
"lookup (∑y∈keys t. Poly_Mapping.single (Some y) (lookup t y)) = (λx. case x of Some y ⇒ lookup t y | _ ⇒ 0)"
proof -
have "(∑x∈keys t. lookup t x when x = y) = lookup t y" for y
proof (cases "y ∈ keys t")
case True
hence "(∑x∈keys t. lookup t x when x = y) = (∑x∈insert y (keys t). lookup t x when x = y)"
by (simp only: insert_absorb)
also have "… = lookup t y + (∑x∈keys t - {y}. lookup t x when x = y)"
by (simp add: sum.insert_remove)
also have "(∑x∈keys t - {y}. lookup t x when x = y) = 0"
by (auto simp: when_def intro: sum.neutral)
finally show ?thesis by simp
next
case False
hence "(∑x∈keys t. lookup t x when x = y) = 0" by (auto simp: when_def intro: sum.neutral)
with False show ?thesis by (simp add: in_keys_iff)
qed
thus ?thesis by (auto simp: lookup_sum lookup_single split: option.split)
qed
lemma keys_extend_indets_subst_aux:
"keys (∑y∈keys t. Poly_Mapping.single (Some y) (lookup t y)) = Some ` keys t"
by (auto simp: lookup_extend_indets_subst_aux simp flip: lookup_not_eq_zero_eq_in_keys split: option.splits)
lemma subst_pp_extend_indets_subst:
"subst_pp extend_indets_subst t = monomial 1 (∑y∈keys t. Poly_Mapping.single (Some y) (lookup t y))"
proof -
have "subst_pp extend_indets_subst t =
monomial (∏y∈keys t. 1 ^ lookup t y) (∑y∈keys t. lookup t y ⋅ Poly_Mapping.single (Some y) 1)"
by (rule subst_pp_by_monomials) (simp only: extend_indets_subst_def)
also have "… = monomial 1 (∑y∈keys t. Poly_Mapping.single (Some y) (lookup t y))"
by simp
finally show ?thesis .
qed
lemma keys_extend_indets:
"keys (extend_indets p) = (λt. ∑y∈keys t. Poly_Mapping.single (Some y) (lookup t y)) ` keys p"
proof -
have "keys (extend_indets p) = (⋃t∈keys p. keys (punit.monom_mult (lookup p t) 0 (subst_pp extend_indets_subst t)))"
unfolding extend_indets_def poly_subst_def using finite_keys
proof (rule keys_sum)
fix s t :: "'a ⇒⇩0 nat"
assume "s ≠ t"
then obtain x where "lookup s x ≠ lookup t x" by (meson poly_mapping_eqI)
have "(∑y∈keys t. monomial (lookup t y) (Some y)) ≠ (∑y∈keys s. monomial (lookup s y) (Some y))"
(is "?l ≠ ?r")
proof
assume "?l = ?r"
hence "lookup ?l (Some x) = lookup ?r (Some x)" by (simp only:)
hence "lookup s x = lookup t x" by (simp add: lookup_extend_indets_subst_aux)
with ‹lookup s x ≠ lookup t x› show False ..
qed
thus "keys (punit.monom_mult (lookup p s) 0 (subst_pp extend_indets_subst s)) ∩
keys (punit.monom_mult (lookup p t) 0 (subst_pp extend_indets_subst t)) =
{}"
by (simp add: subst_pp_extend_indets_subst punit.monom_mult_monomial)
qed
also have "… = (λt. ∑y∈keys t. monomial (lookup t y) (Some y)) ` keys p"
by (auto simp: subst_pp_extend_indets_subst punit.monom_mult_monomial split: if_split_asm)
finally show ?thesis .
qed
lemma indets_extend_indets: "indets (extend_indets p) = Some ` indets (p::_ ⇒⇩0 'a::comm_semiring_1)"
proof (rule set_eqI)
fix x
show "x ∈ indets (extend_indets p) ⟷ x ∈ Some ` indets p"
proof
assume "x ∈ indets (extend_indets p)"
then obtain y where "y ∈ indets p" and "x ∈ indets (monomial (1::'a) (Poly_Mapping.single (Some y) 1))"
unfolding extend_indets_def extend_indets_subst_def by (rule in_indets_poly_substE)
from this(2) indets_monomial_single_subset have "x ∈ {Some y}" ..
hence "x = Some y" by simp
with ‹y ∈ indets p› show "x ∈ Some ` indets p" by (rule rev_image_eqI)
next
assume "x ∈ Some ` indets p"
then obtain y where "y ∈ indets p" and x: "x = Some y" ..
from this(1) obtain t where "t ∈ keys p" and "y ∈ keys t" by (rule in_indetsE)
from this(2) have "Some y ∈ keys (∑y∈keys t. Poly_Mapping.single (Some y) (lookup t y))"
unfolding keys_extend_indets_subst_aux by (rule imageI)
moreover have "(∑y∈keys t. Poly_Mapping.single (Some y) (lookup t y)) ∈ keys (extend_indets p)"
unfolding keys_extend_indets using ‹t ∈ keys p› by (rule imageI)
ultimately show "x ∈ indets (extend_indets p)" unfolding x by (rule in_indetsI)
qed
qed
lemma poly_deg_extend_indets [simp]: "poly_deg (extend_indets p) = poly_deg p"
proof -
have eq: "deg_pm ((∑y∈keys t. Poly_Mapping.single (Some y) (lookup t y))) = deg_pm t"
for t::"'a ⇒⇩0 nat"
proof -
have "deg_pm ((∑y∈keys t. Poly_Mapping.single (Some y) (lookup t y))) = (∑y∈keys t. lookup t y)"
by (simp add: deg_pm_sum deg_pm_single)
also from subset_refl finite_keys have "… = deg_pm t" by (rule deg_pm_superset[symmetric])
finally show ?thesis .
qed
show ?thesis
proof (rule antisym)
show "poly_deg (extend_indets p) ≤ poly_deg p"
proof (rule poly_deg_leI)
fix t
assume "t ∈ keys (extend_indets p)"
then obtain s where "s ∈ keys p" and "t = (∑y∈keys s. Poly_Mapping.single (Some y) (lookup s y))"
unfolding keys_extend_indets ..
from this(2) have "deg_pm t = deg_pm s" by (simp only: eq)
also from ‹s ∈ keys p› have "… ≤ poly_deg p" by (rule poly_deg_max_keys)
finally show "deg_pm t ≤ poly_deg p" .
qed
next
show "poly_deg p ≤ poly_deg (extend_indets p)"
proof (rule poly_deg_leI)
fix t
assume "t ∈ keys p"
hence *: "(∑y∈keys t. Poly_Mapping.single (Some y) (lookup t y)) ∈ keys (extend_indets p)"
unfolding keys_extend_indets by (rule imageI)
have "deg_pm t = deg_pm (∑y∈keys t. Poly_Mapping.single (Some y) (lookup t y))"
by (simp only: eq)
also from * have "… ≤ poly_deg (extend_indets p)" by (rule poly_deg_max_keys)
finally show "deg_pm t ≤ poly_deg (extend_indets p)" .
qed
qed
qed
lemma
shows extend_indets_zero [simp]: "extend_indets 0 = 0"
and extend_indets_one [simp]: "extend_indets 1 = 1"
and extend_indets_monomial: "extend_indets (monomial c t) = punit.monom_mult c 0 (subst_pp extend_indets_subst t)"
and extend_indets_plus: "extend_indets (p + q) = extend_indets p + extend_indets q"
and extend_indets_uminus: "extend_indets (- r) = - extend_indets (r::_ ⇒⇩0 _::comm_ring_1)"
and extend_indets_minus: "extend_indets (r - r') = extend_indets r - extend_indets r'"
and extend_indets_times: "extend_indets (p * q) = extend_indets p * extend_indets q"
and extend_indets_power: "extend_indets (p ^ n) = extend_indets p ^ n"
and extend_indets_sum: "extend_indets (sum f A) = (∑a∈A. extend_indets (f a))"
and extend_indets_prod: "extend_indets (prod f A) = (∏a∈A. extend_indets (f a))"
by (simp_all add: extend_indets_def poly_subst_monomial poly_subst_plus poly_subst_uminus
poly_subst_minus poly_subst_times poly_subst_power poly_subst_sum poly_subst_prod)
lemma extend_indets_zero_iff [simp]: "extend_indets p = 0 ⟷ p = 0"
by (metis (no_types, lifting) imageE imageI keys_extend_indets lookup_zero
not_in_keys_iff_lookup_eq_zero poly_deg_extend_indets poly_deg_zero poly_deg_zero_imp_monomial)
lemma extend_indets_inject:
assumes "extend_indets p = extend_indets (q::_ ⇒⇩0 _::comm_ring_1)"
shows "p = q"
proof -
from assms have "extend_indets (p - q) = 0" by (simp add: extend_indets_minus)
thus ?thesis by simp
qed
corollary inj_extend_indets: "inj (extend_indets::_ ⇒ _ ⇒⇩0 _::comm_ring_1)"
using extend_indets_inject by (intro injI)
lemma poly_subst_extend_indets: "poly_subst f (extend_indets p) = poly_subst (f ∘ Some) p"
by (simp add: extend_indets_def poly_subst_poly_subst extend_indets_subst_def poly_subst_monomial
subst_pp_single o_def)
lemma poly_eval_extend_indets: "poly_eval a (extend_indets p) = poly_eval (a ∘ Some) p"
proof -
have eq: "poly_eval a (extend_indets (monomial c t)) = poly_eval (λx. a (Some x)) (monomial c t)"
for c t
by (simp add: extend_indets_monomial poly_eval_times poly_eval_monomial poly_eval_prod poly_eval_power
subst_pp_def extend_indets_subst_def flip: times_monomial_left)
show ?thesis
by (induct p rule: poly_mapping_plus_induct) (simp_all add: extend_indets_plus poly_eval_plus eq)
qed
lemma lookup_restrict_indets_pp: "lookup (restrict_indets_pp t) = (λx. lookup t (Some x))"
proof -
let ?f = "λz x. lookup t x * lookup (case x of None ⇒ 0 | Some y ⇒ Poly_Mapping.single y 1) z"
have "sum (?f z) (keys t) = lookup t (Some z)" for z
proof (cases "Some z ∈ keys t")
case True
hence "sum (?f z) (keys t) = sum (?f z) (insert (Some z) (keys t))"
by (simp only: insert_absorb)
also have "… = lookup t (Some z) + sum (?f z) (keys t - {Some z})"
by (simp add: sum.insert_remove)
also have "sum (?f z) (keys t - {Some z}) = 0"
by (auto simp: when_def lookup_single intro: sum.neutral split: option.splits)
finally show ?thesis by simp
next
case False
hence "sum (?f z) (keys t) = 0"
by (auto simp: when_def lookup_single intro: sum.neutral split: option.splits)
with False show ?thesis by (simp add: in_keys_iff)
qed
thus ?thesis by (auto simp: restrict_indets_pp_def restrict_indets_subst_def lookup_sum)
qed
lemma keys_restrict_indets_pp: "keys (restrict_indets_pp t) = the ` (keys t - {None})"
proof (rule set_eqI)
fix x
show "x ∈ keys (restrict_indets_pp t) ⟷ x ∈ the ` (keys t - {None})"
proof
assume "x ∈ keys (restrict_indets_pp t)"
hence "Some x ∈ keys t" by (simp add: lookup_restrict_indets_pp flip: lookup_not_eq_zero_eq_in_keys)
hence "Some x ∈ keys t - {None}" by blast
moreover have "x = the (Some x)" by simp
ultimately show "x ∈ the ` (keys t - {None})" by (rule rev_image_eqI)
next
assume "x ∈ the ` (keys t - {None})"
then obtain y where "y ∈ keys t - {None}" and "x = the y" ..
hence "Some x ∈ keys t" by auto
thus "x ∈ keys (restrict_indets_pp t)"
by (simp add: lookup_restrict_indets_pp flip: lookup_not_eq_zero_eq_in_keys)
qed
qed
lemma subst_pp_restrict_indets_subst:
"subst_pp (λx. monomial 1 (restrict_indets_subst x)) t = monomial 1 (restrict_indets_pp t)"
by (simp add: subst_pp_def monomial_power_map_scale restrict_indets_pp_def flip: punit.monomial_prod_sum)
lemma restrict_indets_pp_zero [simp]: "restrict_indets_pp 0 = 0"
by (simp add: restrict_indets_pp_def)
lemma restrict_indets_pp_plus: "restrict_indets_pp (s + t) = restrict_indets_pp s + restrict_indets_pp t"
by (rule poly_mapping_eqI) (simp add: lookup_add lookup_restrict_indets_pp)
lemma restrict_indets_pp_except_None [simp]:
"restrict_indets_pp (except t {None}) = restrict_indets_pp t"
by (rule poly_mapping_eqI) (simp add: lookup_add lookup_restrict_indets_pp lookup_except)
lemma deg_pm_restrict_indets_pp: "deg_pm (restrict_indets_pp t) + lookup t None = deg_pm t"
proof -
have "deg_pm t = sum (lookup t) (insert None (keys t))" by (rule deg_pm_superset) auto
also from finite_keys have "… = lookup t None + sum (lookup t) (keys t - {None})"
by (rule sum.insert_remove)
also have "sum (lookup t) (keys t - {None}) = (∑x∈keys t. lookup t x * deg_pm (restrict_indets_subst x))"
by (intro sum.mono_neutral_cong_left) (auto simp: restrict_indets_subst_def deg_pm_single)
also have "… = deg_pm (restrict_indets_pp t)"
by (simp only: restrict_indets_pp_def deg_pm_sum deg_pm_map_scale)
finally show ?thesis by simp
qed
lemma keys_restrict_indets_subset: "keys (restrict_indets p) ⊆ restrict_indets_pp ` keys p"
proof
fix t
assume "t ∈ keys (restrict_indets p)"
also have "… = keys (∑t∈keys p. monomial (lookup p t) (restrict_indets_pp t))"
by (simp add: restrict_indets_def poly_subst_def subst_pp_restrict_indets_subst punit.monom_mult_monomial)
also have "… ⊆ (⋃t∈keys p. keys (monomial (lookup p t) (restrict_indets_pp t)))"
by (rule keys_sum_subset)
also have "… = restrict_indets_pp ` keys p" by (auto split: if_split_asm)
finally show "t ∈ restrict_indets_pp ` keys p" .
qed
lemma keys_restrict_indets:
assumes "None ∉ indets p"
shows "keys (restrict_indets p) = restrict_indets_pp ` keys p"
proof -
have "keys (restrict_indets p) = keys (∑t∈keys p. monomial (lookup p t) (restrict_indets_pp t))"
by (simp add: restrict_indets_def poly_subst_def subst_pp_restrict_indets_subst punit.monom_mult_monomial)
also from finite_keys have "… = (⋃t∈keys p. keys (monomial (lookup p t) (restrict_indets_pp t)))"
proof (rule keys_sum)
fix s t
assume "s ∈ keys p"
hence "keys s ⊆ indets p" by (rule keys_subset_indets)
with assms have "None ∉ keys s" by blast
assume "t ∈ keys p"
hence "keys t ⊆ indets p" by (rule keys_subset_indets)
with assms have "None ∉ keys t" by blast
assume "s ≠ t"
then obtain x where neq: "lookup s x ≠ lookup t x" by (meson poly_mapping_eqI)
have "x ≠ None"
proof
assume "x = None"
with ‹None ∉ keys s› and ‹None ∉ keys t› have "x ∉ keys s" and "x ∉ keys t" by blast+
with neq show False by (simp add: in_keys_iff)
qed
then obtain y where x: "x = Some y" by blast
have "restrict_indets_pp t ≠ restrict_indets_pp s"
proof
assume "restrict_indets_pp t = restrict_indets_pp s"
hence "lookup (restrict_indets_pp t) y = lookup (restrict_indets_pp s) y" by (simp only:)
hence "lookup s x = lookup t x" by (simp add: x lookup_restrict_indets_pp)
with neq show False ..
qed
thus "keys (monomial (lookup p s) (restrict_indets_pp s)) ∩
keys (monomial (lookup p t) (restrict_indets_pp t)) = {}"
by (simp add: subst_pp_extend_indets_subst)
qed
also have "… = restrict_indets_pp ` keys p" by (auto split: if_split_asm)
finally show ?thesis .
qed
lemma indets_restrict_indets_subset: "indets (restrict_indets p) ⊆ the ` (indets p - {None})"
proof
fix x
assume "x ∈ indets (restrict_indets p)"
then obtain t where "t ∈ keys (restrict_indets p)" and "x ∈ keys t" by (rule in_indetsE)
from this(1) keys_restrict_indets_subset have "t ∈ restrict_indets_pp ` keys p" ..
then obtain s where "s ∈ keys p" and "t = restrict_indets_pp s" ..
from ‹x ∈ keys t› this(2) have "x ∈ the ` (keys s - {None})" by (simp only: keys_restrict_indets_pp)
also from ‹s ∈ keys p› have "… ⊆ the ` (indets p - {None})"
by (intro image_mono Diff_mono keys_subset_indets subset_refl)
finally show "x ∈ the ` (indets p - {None})" .
qed
lemma poly_deg_restrict_indets_le: "poly_deg (restrict_indets p) ≤ poly_deg p"
proof (rule poly_deg_leI)
fix t
assume "t ∈ keys (restrict_indets p)"
hence "t ∈ restrict_indets_pp ` keys p" using keys_restrict_indets_subset ..
then obtain s where "s ∈ keys p" and "t = restrict_indets_pp s" ..
from this(2) have "deg_pm t + lookup s None = deg_pm s"
by (simp only: deg_pm_restrict_indets_pp)
also from ‹s ∈ keys p› have "… ≤ poly_deg p" by (rule poly_deg_max_keys)
finally show "deg_pm t ≤ poly_deg p" by simp
qed
lemma
shows restrict_indets_zero [simp]: "restrict_indets 0 = 0"
and restrict_indets_one [simp]: "restrict_indets 1 = 1"
and restrict_indets_monomial: "restrict_indets (monomial c t) = monomial c (restrict_indets_pp t)"
and restrict_indets_plus: "restrict_indets (p + q) = restrict_indets p + restrict_indets q"
and restrict_indets_uminus: "restrict_indets (- r) = - restrict_indets (r::_ ⇒⇩0 _::comm_ring_1)"
and restrict_indets_minus: "restrict_indets (r - r') = restrict_indets r - restrict_indets r'"
and restrict_indets_times: "restrict_indets (p * q) = restrict_indets p * restrict_indets q"
and restrict_indets_power: "restrict_indets (p ^ n) = restrict_indets p ^ n"
and restrict_indets_sum: "restrict_indets (sum f A) = (∑a∈A. restrict_indets (f a))"
and restrict_indets_prod: "restrict_indets (prod f A) = (∏a∈A. restrict_indets (f a))"
by (simp_all add: restrict_indets_def poly_subst_monomial poly_subst_plus poly_subst_uminus
poly_subst_minus poly_subst_times poly_subst_power poly_subst_sum poly_subst_prod
subst_pp_restrict_indets_subst punit.monom_mult_monomial)
lemma restrict_extend_indets [simp]: "restrict_indets (extend_indets p) = p"
unfolding extend_indets_def restrict_indets_def poly_subst_poly_subst
by (rule poly_subst_id)
(simp add: extend_indets_subst_def restrict_indets_subst_def poly_subst_monomial subst_pp_single)
lemma extend_restrict_indets:
assumes "None ∉ indets p"
shows "extend_indets (restrict_indets p) = p"
unfolding extend_indets_def restrict_indets_def poly_subst_poly_subst
proof (rule poly_subst_id)
fix x
assume "x ∈ indets p"
with assms have "x ≠ None" by meson
then obtain y where x: "x = Some y" by blast
thus "poly_subst extend_indets_subst (monomial 1 (restrict_indets_subst x)) =
monomial 1 (Poly_Mapping.single x 1)"
by (simp add: extend_indets_subst_def restrict_indets_subst_def poly_subst_monomial subst_pp_single)
qed
lemma restrict_indets_dehomogenize [simp]: "restrict_indets (dehomogenize None p) = restrict_indets p"
proof -
have eq: "poly_subst (λx. (monomial 1 (restrict_indets_subst x))) (dehomo_subst None y) =
monomial 1 (restrict_indets_subst y)" for y::"'x option"
by (auto simp: restrict_indets_subst_def dehomo_subst_def poly_subst_monomial subst_pp_single)
show ?thesis by (simp only: dehomogenize_def restrict_indets_def poly_subst_poly_subst eq)
qed
corollary restrict_indets_comp_dehomogenize: "restrict_indets ∘ dehomogenize None = restrict_indets"
by (rule ext) (simp only: o_def restrict_indets_dehomogenize)
corollary extend_restrict_indets_eq_dehomogenize:
"extend_indets (restrict_indets p) = dehomogenize None p"
proof -
have "extend_indets (restrict_indets p) = extend_indets (restrict_indets (dehomogenize None p))"
by simp
also have "… = dehomogenize None p"
proof (intro extend_restrict_indets notI)
assume "None ∈ indets (dehomogenize None p)"
hence "None ∈ indets p - {None}" using indets_dehomogenize ..
thus False by simp
qed
finally show ?thesis .
qed
corollary extend_indets_comp_restrict_indets: "extend_indets ∘ restrict_indets = dehomogenize None"
by (rule ext) (simp only: o_def extend_restrict_indets_eq_dehomogenize)
lemma restrict_homogenize_extend_indets [simp]:
"restrict_indets (homogenize None (extend_indets p)) = p"
proof -
have "restrict_indets (homogenize None (extend_indets p)) =
restrict_indets (dehomogenize None (homogenize None (extend_indets p)))"
by (simp only: restrict_indets_dehomogenize)
also have "… = restrict_indets (dehomogenize None (extend_indets p))"
by (simp only: dehomogenize_homogenize)
also have "… = p" by simp
finally show ?thesis .
qed
lemma dehomogenize_extend_indets [simp]: "dehomogenize None (extend_indets p) = extend_indets p"
by (simp add: indets_extend_indets)
lemma restrict_indets_ideal: "restrict_indets ` ideal F = ideal (restrict_indets ` F)"
using restrict_indets_plus restrict_indets_times
proof (rule image_ideal_eq_surj)
from restrict_extend_indets show "surj restrict_indets" by (rule surjI)
qed
lemma ideal_restrict_indets:
"ideal G = ideal (homogenize None ` extend_indets ` F) ⟹ ideal (restrict_indets ` G) = ideal F"
by (simp flip: restrict_indets_ideal) (simp add: restrict_indets_ideal image_image)
lemma extend_indets_ideal: "extend_indets ` ideal F = ideal (extend_indets ` F) ∩ P[- {None}]"
proof -
have "extend_indets ` ideal F = extend_indets ` restrict_indets ` ideal (extend_indets ` F)"
by (simp add: restrict_indets_ideal image_image)
also have "… = ideal (extend_indets ` F) ∩ P[- {None}]"
by (simp add: extend_restrict_indets_eq_dehomogenize dehomogenize_ideal image_image)
finally show ?thesis .
qed
corollary extend_indets_ideal_subset: "extend_indets ` ideal F ⊆ ideal (extend_indets ` F)"
by (simp add: extend_indets_ideal)
subsection ‹Canonical Isomorphisms between ‹P[X,Y]› and ‹P[X][Y]›: ‹focus› and ‹flatten››
definition focus :: "'x set ⇒ (('x ⇒⇩0 nat) ⇒⇩0 'a) ⇒ (('x ⇒⇩0 nat) ⇒⇩0 ('x ⇒⇩0 nat) ⇒⇩0 'a::comm_monoid_add)"
where "focus X p = (∑t∈keys p. monomial (monomial (lookup p t) (except t X)) (except t (- X)))"
definition flatten :: "('a ⇒⇩0 'a ⇒⇩0 'b) ⇒ ('a::comm_powerprod ⇒⇩0 'b::semiring_1)"
where "flatten p = (∑t∈keys p. punit.monom_mult 1 t (lookup p t))"
lemma focus_superset:
assumes "finite A" and "keys p ⊆ A"
shows "focus X p = (∑t∈A. monomial (monomial (lookup p t) (except t X)) (except t (- X)))"
unfolding focus_def using assms by (rule sum.mono_neutral_left) (simp add: in_keys_iff)
lemma keys_focus: "keys (focus X p) = (λt. except t (- X)) ` keys p"
proof
have "keys (focus X p) ⊆ (⋃t∈keys p. keys (monomial (monomial (lookup p t) (except t X)) (except t (- X))))"
unfolding focus_def by (rule keys_sum_subset)
also have "… ⊆ (⋃t∈keys p. {except t (- X)})" by (intro UN_mono subset_refl) simp
also have "… = (λt. except t (- X)) ` keys p" by (rule UNION_singleton_eq_range)
finally show "keys (focus X p) ⊆ (λt. except t (- X)) ` keys p" .
next
{
fix s
assume "s ∈ keys p"
have "lookup (focus X p) (except s (- X)) =
(∑t∈keys p. monomial (lookup p t) (except t X) when except t (- X) = except s (- X))"
(is "_ = ?p")
by (simp only: focus_def lookup_sum lookup_single)
also have "… ≠ 0"
proof
have "lookup ?p (except s X) =
(∑t∈keys p. lookup p t when except t X = except s X ∧ except t (- X) = except s (- X))"
by (simp add: lookup_sum lookup_single when_def if_distrib if_distribR)
(metis (no_types, hide_lams) lookup_single_eq lookup_single_not_eq lookup_zero)
also have "… = (∑t∈{s}. lookup p t)"
proof (intro sum.mono_neutral_cong_right ballI)
fix t
assume "t ∈ keys p - {s}"
hence "t ≠ s" by simp
hence "except t X + except t (- X) ≠ except s X + except s (- X)"
by (simp flip: except_decomp)
thus "(lookup p t when except t X = except s X ∧ except t (- X) = except s (- X)) = 0"
by (auto simp: when_def)
next
from ‹s ∈ keys p› show "{s} ⊆ keys p" by simp
qed simp_all
also from ‹s ∈ keys p› have "… ≠ 0" by (simp add: in_keys_iff)
finally have "except s X ∈ keys ?p" by (simp add: in_keys_iff)
moreover assume "?p = 0"
ultimately show False by simp
qed
finally have "except s (- X) ∈ keys (focus X p)" by (simp add: in_keys_iff)
}
thus "(λt. except t (- X)) ` keys p ⊆ keys (focus X p)" by blast
qed
lemma keys_coeffs_focus_subset:
assumes "c ∈ range (lookup (focus X p))"
shows "keys c ⊆ (λt. except t X) ` keys p"
proof -
from assms obtain s where "c = lookup (focus X p) s" ..
hence "keys c = keys (lookup (focus X p) s)" by (simp only:)
also have "… ⊆ (⋃t∈keys p. keys (lookup (monomial (monomial (lookup p t) (except t X)) (except t (- X))) s))"
unfolding focus_def lookup_sum by (rule keys_sum_subset)
also from subset_refl have "… ⊆ (⋃t∈keys p. {except t X})"
by (rule UN_mono) (simp add: lookup_single when_def)
also have "… = (λt. except t X) ` keys p" by (rule UNION_singleton_eq_range)
finally show ?thesis .
qed
lemma focus_in_Polys':
assumes "p ∈ P[Y]"
shows "focus X p ∈ P[Y ∩ X]"
proof (intro PolysI subsetI)
fix t
assume "t ∈ keys (focus X p)"
then obtain s where "s ∈ keys p" and t: "t = except s (- X)" unfolding keys_focus ..
note this(1)
also from assms have "keys p ⊆ .[Y]" by (rule PolysD)
finally have "keys s ⊆ Y" by (rule PPsD)
hence "keys t ⊆ Y ∩ X" by (simp add: t keys_except le_infI1)
thus "t ∈ .[Y ∩ X]" by (rule PPsI)
qed
corollary focus_in_Polys: "focus X p ∈ P[X]"
proof -
have "p ∈ P[UNIV]" by simp
hence "focus X p ∈ P[UNIV ∩ X]" by (rule focus_in_Polys')
thus ?thesis by simp
qed
lemma focus_coeffs_subset_Polys':
assumes "p ∈ P[Y]"
shows "range (lookup (focus X p)) ⊆ P[Y - X]"
proof (intro subsetI PolysI)
fix c t
assume "c ∈ range (lookup (focus X p))"
hence "keys c ⊆ (λt. except t X) ` keys p" by (rule keys_coeffs_focus_subset)
moreover assume "t ∈ keys c"
ultimately have "t ∈ (λt. except t X) ` keys p" ..
then obtain s where "s ∈ keys p" and t: "t = except s X" ..
note this(1)
also from assms have "keys p ⊆ .[Y]" by (rule PolysD)
finally have "keys s ⊆ Y" by (rule PPsD)
hence "keys t ⊆ Y - X" by (simp add: t keys_except Diff_mono)
thus "t ∈ .[Y - X]" by (rule PPsI)
qed
corollary focus_coeffs_subset_Polys: "range (lookup (focus X p)) ⊆ P[- X]"
proof -
have "p ∈ P[UNIV]" by simp
hence "range (lookup (focus X p)) ⊆ P[UNIV - X]" by (rule focus_coeffs_subset_Polys')
thus ?thesis by (simp only: Compl_eq_Diff_UNIV)
qed
corollary lookup_focus_in_Polys: "lookup (focus X p) t ∈ P[- X]"
using focus_coeffs_subset_Polys by blast
lemma focus_zero [simp]: "focus X 0 = 0"
by (simp add: focus_def)
lemma focus_eq_zero_iff [iff]: "focus X p = 0 ⟷ p = 0"
by (simp only: keys_focus flip: keys_eq_empty_iff) simp
lemma focus_one [simp]: "focus X 1 = 1"
by (simp add: focus_def)
lemma focus_monomial: "focus X (monomial c t) = monomial (monomial c (except t X)) (except t (- X))"
by (simp add: focus_def)
lemma focus_uminus [simp]: "focus X (- p) = - focus X p"
by (simp add: focus_def keys_uminus single_uminus sum_negf)
lemma focus_plus: "focus X (p + q) = focus X p + focus X q"
proof -
have "finite (keys p ∪ keys q)" by simp
moreover have "keys (p + q) ⊆ keys p ∪ keys q" by (rule Poly_Mapping.keys_add)
ultimately show ?thesis
by (simp add: focus_superset[where A="keys p ∪ keys q"] lookup_add single_add sum.distrib)
qed
lemma focus_minus: "focus X (p - q) = focus X p - focus X (q::_ ⇒⇩0 _::ab_group_add)"
by (simp only: diff_conv_add_uminus focus_plus focus_uminus)
lemma focus_times: "focus X (p * q) = focus X p * focus X q"
proof -
have eq: "focus X (monomial c s * q) = focus X (monomial c s) * focus X q" for c s
proof -
have "focus X (monomial c s * q) = focus X (punit.monom_mult c s q)"
by (simp only: times_monomial_left)
also have "… = (∑t∈(+) s ` keys q. monomial (monomial (lookup (punit.monom_mult c s q) t)
(except t X)) (except t (- X)))"
by (rule focus_superset) (simp_all add: punit.keys_monom_mult_subset[simplified])
also have "… = (∑t∈keys q. ((λt. monomial (monomial (lookup (punit.monom_mult c s q) t)
(except t X)) (except t (- X))) ∘ ((+) s)) t)"
by (rule sum.reindex) simp
also have "… = monomial (monomial c (except s X)) (except s (- X)) *
(∑t∈keys q. monomial (monomial (lookup q t) (except t X)) (except t (- X)))"
by (simp add: o_def punit.lookup_monom_mult except_plus times_monomial_monomial sum_distrib_left)
also have "… = focus X (monomial c s) * focus X q"
by (simp only: focus_monomial focus_def[where p=q])
finally show ?thesis .
qed
show ?thesis by (induct p rule: poly_mapping_plus_induct) (simp_all add: ring_distribs focus_plus eq)
qed
lemma focus_sum: "focus X (sum f I) = (∑i∈I. focus X (f i))"
by (induct I rule: infinite_finite_induct) (simp_all add: focus_plus)
lemma focus_prod: "focus X (prod f I) = (∏i∈I. focus X (f i))"
by (induct I rule: infinite_finite_induct) (simp_all add: focus_times)
lemma focus_power [simp]: "focus X (f ^ m) = focus X f ^ m"
by (induct m) (simp_all add: focus_times)
lemma focus_Polys:
assumes "p ∈ P[X]"
shows "focus X p = (∑t∈keys p. monomial (monomial (lookup p t) 0) t)"
unfolding focus_def
proof (rule sum.cong)
fix t
assume "t ∈ keys p"
also from assms have "… ⊆ .[X]" by (rule PolysD)
finally have "keys t ⊆ X" by (rule PPsD)
hence "except t X = 0" and "except t (- X) = t" by (rule except_eq_zeroI, auto simp: except_id_iff)
thus "monomial (monomial (lookup p t) (except t X)) (except t (- X)) =
monomial (monomial (lookup p t) 0) t" by simp
qed (fact refl)
corollary lookup_focus_Polys: "p ∈ P[X] ⟹ lookup (focus X p) t = monomial (lookup p t) 0"
by (simp add: focus_Polys lookup_sum lookup_single when_def in_keys_iff)
lemma focus_Polys_Compl:
assumes "p ∈ P[- X]"
shows "focus X p = monomial p 0"
proof -
have "focus X p = (∑t∈keys p. monomial (monomial (lookup p t) t) 0)" unfolding focus_def
proof (rule sum.cong)
fix t
assume "t ∈ keys p"
also from assms have "… ⊆ .[- X]" by (rule PolysD)
finally have "keys t ⊆ - X" by (rule PPsD)
hence "except t (- X) = 0" and "except t X = t" by (rule except_eq_zeroI, auto simp: except_id_iff)
thus "monomial (monomial (lookup p t) (except t X)) (except t (- X)) =
monomial (monomial (lookup p t) t) 0" by simp
qed (fact refl)
also have "… = monomial (∑t∈keys p. monomial (lookup p t) t) 0" by (simp only: monomial_sum)
also have "… = monomial p 0" by (simp only: poly_mapping_sum_monomials)
finally show ?thesis .
qed
corollary focus_empty [simp]: "focus {} p = monomial p 0"
by (rule focus_Polys_Compl) simp
lemma focus_Int:
assumes "p ∈ P[Y]"
shows "focus (X ∩ Y) p = focus X p"
unfolding focus_def using refl
proof (rule sum.cong)
fix t
assume "t ∈ keys p"
also from assms have "… ⊆ .[Y]" by (rule PolysD)
finally have "keys t ⊆ Y" by (rule PPsD)
hence "keys t ⊆ X ∪ Y" by blast
hence "except t (X ∩ Y) = except t X + except t Y" by (rule except_Int)
also from ‹keys t ⊆ Y› have "except t Y = 0" by (rule except_eq_zeroI)
finally have eq: "except t (X ∩ Y) = except t X" by simp
have "except t (- (X ∩ Y)) = except (except t (- Y)) (- X)" by (simp add: except_except Un_commute)
also from ‹keys t ⊆ Y› have "except t (- Y) = t" by (auto simp: except_id_iff)
finally show "monomial (monomial (lookup p t) (except t (X ∩ Y))) (except t (- (X ∩ Y))) =
monomial (monomial (lookup p t) (except t X)) (except t (- X))" by (simp only: eq)
qed
lemma range_focusD:
assumes "p ∈ range (focus X)"
shows "p ∈ P[X]" and "range (lookup p) ⊆ P[- X]" and "lookup p t ∈ P[- X]"
using assms by (auto intro: focus_in_Polys lookup_focus_in_Polys)
lemma range_focusI:
assumes "p ∈ P[X]" and "lookup p ` keys (p::_ ⇒⇩0 _ ⇒⇩0 _::semiring_1) ⊆ P[- X]"
shows "p ∈ range (focus X)"
using assms
proof (induct p rule: poly_mapping_plus_induct_Polys)
case 0
show ?case by simp
next
case (plus p c t)
from plus.hyps(3) have 1: "keys (monomial c t) = {t}" by simp
also from plus.hyps(4) have "… ∩ keys p = {}" by simp
finally have "keys (monomial c t + p) = keys (monomial c t) ∪ keys p" by (rule keys_add[symmetric])
hence 2: "keys (monomial c t + p) = insert t (keys p)" by (simp only: 1 flip: insert_is_Un)
from ‹t ∈ .[X]› have "keys t ⊆ X" by (rule PPsD)
hence eq1: "except t X = 0" and eq2: "except t (- X) = t"
by (rule except_eq_zeroI, auto simp: except_id_iff)
from plus.hyps(3, 4) plus.prems have "c ∈ P[- X]" and "lookup p ` keys p ⊆ P[- X]"
by (simp_all add: 2 lookup_add lookup_single in_keys_iff)
(smt add.commute add.right_neutral image_cong plus.hyps(4) when_simps(2))
from this(2) have "p ∈ range (focus X)" by (rule plus.hyps)
then obtain q where p: "p = focus X q" ..
moreover from ‹c ∈ P[- X]› have "monomial c t = focus X (monomial 1 t * c)"
by (simp add: focus_times focus_monomial eq1 eq2 focus_Polys_Compl times_monomial_monomial)
ultimately have "monomial c t + p = focus X (monomial 1 t * c + q)" by (simp only: focus_plus)
thus ?case by (rule range_eqI)
qed
lemma inj_focus: "inj ((focus X) :: (('x ⇒⇩0 nat) ⇒⇩0 'a::ab_group_add) ⇒ _)"
proof (rule injI)
fix p q :: "('x ⇒⇩0 nat) ⇒⇩0 'a"
assume "focus X p = focus X q"
hence "focus X (p - q) = 0" by (simp add: focus_minus)
thus "p = q" by simp
qed
lemma flatten_superset:
assumes "finite A" and "keys p ⊆ A"
shows "flatten p = (∑t∈A. punit.monom_mult 1 t (lookup p t))"
unfolding flatten_def using assms by (rule sum.mono_neutral_left) (simp add: in_keys_iff)
lemma keys_flatten_subset: "keys (flatten p) ⊆ (⋃t∈keys p. (+) t ` keys (lookup p t))"
proof -
have "keys (flatten p) ⊆ (⋃t∈keys p. keys (punit.monom_mult 1 t (lookup p t)))"
unfolding flatten_def by (rule keys_sum_subset)
also from subset_refl have "… ⊆ (⋃t∈keys p. (+) t ` keys (lookup p t))"
by (rule UN_mono) (rule punit.keys_monom_mult_subset[simplified])
finally show ?thesis .
qed
lemma flatten_in_Polys:
assumes "p ∈ P[X]" and "lookup p ` keys p ⊆ P[Y]"
shows "flatten p ∈ P[X ∪ Y]"
proof (intro PolysI subsetI)
fix t
assume "t ∈ keys (flatten p)"
also have "… ⊆ (⋃t∈keys p. (+) t ` keys (lookup p t))" by (rule keys_flatten_subset)
finally obtain s where "s ∈ keys p" and "t ∈ (+) s ` keys (lookup p s)" ..
from this(2) obtain s' where "s' ∈ keys (lookup p s)" and t: "t = s + s'" ..
from assms(1) have "keys p ⊆ .[X]" by (rule PolysD)
with ‹s ∈ keys p› have "s ∈ .[X]" ..
also have "… ⊆ .[X ∪ Y]" by (rule PPs_mono) simp
finally have 1: "s ∈ .[X ∪ Y]" .
from ‹s ∈ keys p› have "lookup p s ∈ lookup p ` keys p" by (rule imageI)
also have "… ⊆ P[Y]" by fact
finally have "keys (lookup p s) ⊆ .[Y]" by (rule PolysD)
with ‹s' ∈ _› have "s' ∈ .[Y]" ..
also have "… ⊆ .[X ∪ Y]" by (rule PPs_mono) simp
finally have "s' ∈ .[X ∪ Y]" .
with 1 show "t ∈ .[X ∪ Y]" unfolding t by (rule PPs_closed_plus)
qed
lemma flatten_zero [simp]: "flatten 0 = 0"
by (simp add: flatten_def)
lemma flatten_one [simp]: "flatten 1 = 1"
by (simp add: flatten_def)
lemma flatten_monomial: "flatten (monomial c t) = punit.monom_mult 1 t c"
by (simp add: flatten_def)
lemma flatten_uminus [simp]: "flatten (- p) = - flatten (p::_ ⇒⇩0 _ ⇒⇩0 _::ring)"
by (simp add: flatten_def keys_uminus punit.monom_mult_uminus_right sum_negf)
lemma flatten_plus: "flatten (p + q) = flatten p + flatten q"
proof -
have "finite (keys p ∪ keys q)" by simp
moreover have "keys (p + q) ⊆ keys p ∪ keys q" by (rule Poly_Mapping.keys_add)
ultimately show ?thesis
by (simp add: flatten_superset[where A="keys p ∪ keys q"] punit.monom_mult_dist_right lookup_add
sum.distrib)
qed
lemma flatten_minus: "flatten (p - q) = flatten p - flatten (q::_ ⇒⇩0 _ ⇒⇩0 _::ring)"
by (simp only: diff_conv_add_uminus flatten_plus flatten_uminus)
lemma flatten_times: "flatten (p * q) = flatten p * flatten (q::_ ⇒⇩0 _ ⇒⇩0 'b::comm_semiring_1)"
proof -
have eq: "flatten (monomial c s * q) = flatten (monomial c s) * flatten q" for c s
proof -
have eq: "monomial 1 (t + s) = monomial 1 s * monomial (1::'b) t" for t
by (simp add: times_monomial_monomial add.commute)
have "flatten (monomial c s * q) = flatten (punit.monom_mult c s q)"
by (simp only: times_monomial_left)
also have "… = (∑t∈(+) s ` keys q. punit.monom_mult 1 t (lookup (punit.monom_mult c s q) t))"
by (rule flatten_superset) (simp_all add: punit.keys_monom_mult_subset[simplified])
also have "… = (∑t∈keys q. ((λt. punit.monom_mult 1 t (lookup (punit.monom_mult c s q) t)) ∘ (+) s) t)"
by (rule sum.reindex) simp
thm times_monomial_left
also have "… = punit.monom_mult 1 s c *
(∑t∈keys q. punit.monom_mult 1 t (lookup q t))"
by (simp add: o_def punit.lookup_monom_mult sum_distrib_left)
(simp add: algebra_simps eq flip: times_monomial_left)
also have "… = flatten (monomial c s) * flatten q"
by (simp only: flatten_monomial flatten_def[where p=q])
finally show ?thesis .
qed
show ?thesis by (induct p rule: poly_mapping_plus_induct) (simp_all add: ring_distribs flatten_plus eq)
qed
lemma flatten_monom_mult:
"flatten (punit.monom_mult c t p) = punit.monom_mult 1 t (c * flatten (p::_ ⇒⇩0 _ ⇒⇩0 'b::comm_semiring_1))"
by (simp only: flatten_times flatten_monomial mult.assoc flip: times_monomial_left)
lemma flatten_sum: "flatten (sum f I) = (∑i∈I. flatten (f i))"
by (induct I rule: infinite_finite_induct) (simp_all add: flatten_plus)
lemma flatten_prod: "flatten (prod f I) = (∏i∈I. flatten (f i :: _ ⇒⇩0 _::comm_semiring_1))"
by (induct I rule: infinite_finite_induct) (simp_all add: flatten_times)
lemma flatten_power [simp]: "flatten (f ^ m) = flatten (f:: _ ⇒⇩0 _::comm_semiring_1) ^ m"
by (induct m) (simp_all add: flatten_times)
lemma surj_flatten: "surj flatten"
proof (rule surjI)
fix p
show "flatten (monomial p 0) = p" by (simp add: flatten_monomial)
qed
lemma flatten_focus [simp]: "flatten (focus X p) = p"
by (induct p rule: poly_mapping_plus_induct)
(simp_all add: focus_plus flatten_plus focus_monomial flatten_monomial
punit.monom_mult_monomial add.commute flip: except_decomp)
lemma focus_flatten:
assumes "p ∈ P[X]" and "lookup p ` keys p ⊆ P[- X]"
shows "focus X (flatten p) = p"
proof -
from assms have "p ∈ range (focus X)" by (rule range_focusI)
then obtain q where "p = focus X q" ..
thus ?thesis by simp
qed
lemma image_focus_ideal: "focus X ` ideal F = ideal (focus X ` F) ∩ range (focus X)"
proof
from focus_plus focus_times have "focus X ` ideal F ⊆ ideal (focus X ` F)"
by (rule image_ideal_subset)
moreover from subset_UNIV have "focus X ` ideal F ⊆ range (focus X)" by (rule image_mono)
ultimately show "focus X ` ideal F ⊆ ideal (focus X ` F) ∩ range (focus X)" by blast
next
show "ideal (focus X ` F) ∩ range (focus X) ⊆ focus X ` ideal F"
proof
fix p
assume "p ∈ ideal (focus X ` F) ∩ range (focus X)"
hence "p ∈ ideal (focus X ` F)" and "p ∈ range (focus X)" by simp_all
from this(1) obtain F0 q where "F0 ⊆ focus X ` F" and p: "p = (∑f'∈F0. q f' * f')"
by (rule ideal.spanE)
from this(1) obtain F' where "F' ⊆ F" and F0: "F0 = focus X ` F'" by (rule subset_imageE)
from inj_focus subset_UNIV have "inj_on (focus X) F'" by (rule inj_on_subset)
from ‹p ∈ range _› obtain p' where "p = focus X p'" ..
hence "p = focus X (flatten p)" by simp
also from ‹inj_on _ F'› have "… = focus X (∑f'∈F'. flatten (q (focus X f')) * f')"
by (simp add: p F0 sum.reindex flatten_sum flatten_times)
finally have "p = focus X (∑f'∈F'. flatten (q (focus X f')) * f')" .
moreover have "(∑f'∈F'. flatten (q (focus X f')) * f') ∈ ideal F"
proof
show "(∑f'∈F'. flatten (q (focus X f')) * f') ∈ ideal F'" by (rule ideal.sum_in_spanI)
next
from ‹F' ⊆ F› show "ideal F' ⊆ ideal F" by (rule ideal.span_mono)
qed
ultimately show "p ∈ focus X ` ideal F" by (rule image_eqI)
qed
qed
lemma image_flatten_ideal: "flatten ` ideal F = ideal (flatten ` F)"
using flatten_plus flatten_times surj_flatten by (rule image_ideal_eq_surj)
lemma poly_eval_focus:
"poly_eval a (focus X p) = poly_subst (λx. if x ∈ X then a x else monomial 1 (Poly_Mapping.single x 1)) p"
proof -
let ?b = "λx. if x ∈ X then a x else monomial 1 (Poly_Mapping.single x 1)"
have *: "lookup (punit.monom_mult (monomial (lookup p t) (except t X)) 0
(subst_pp (λx. monomial (a x) 0) (except t (- X)))) 0 =
punit.monom_mult (lookup p t) 0 (subst_pp ?b t)" for t
proof -
have 1: "subst_pp ?b (except t X) = monomial 1 (except t X)"
by (rule subst_pp_id) (simp add: keys_except)
from refl have 2: "subst_pp ?b (except t (- X)) = subst_pp a (except t (-X))"
by (rule subst_pp_cong) (simp add: keys_except)
have "lookup (punit.monom_mult (monomial (lookup p t) (except t X)) 0
(subst_pp (λx. monomial (a x) 0) (except t (- X)))) 0 =
punit.monom_mult (lookup p t) (except t X) (subst_pp a (except t (- X)))"
by (simp add: lookup_times_zero subst_pp_def lookup_prod_zero lookup_power_zero
flip: times_monomial_left)
also have "… = punit.monom_mult (lookup p t) 0 (monomial 1 (except t X) * subst_pp a (except t (- X)))"
by (simp add: times_monomial_monomial flip: times_monomial_left mult.assoc)
also have "… = punit.monom_mult (lookup p t) 0 (subst_pp ?b (except t X + except t (- X)))"
by (simp only: subst_pp_plus 1 2)
also have "… = punit.monom_mult (lookup p t) 0 (subst_pp ?b t)" by (simp flip: except_decomp)
finally show ?thesis .
qed
show ?thesis by (simp add: poly_eval_def focus_def poly_subst_sum lookup_sum poly_subst_monomial *
flip: poly_subst_def)
qed
corollary poly_eval_poly_eval_focus:
"poly_eval a (poly_eval b (focus X p)) = poly_eval (λx::'x. if x ∈ X then poly_eval a (b x) else a x) p"
proof -
have eq: "monomial (lookup (poly_subst (λy. monomial (a y) (0::'x ⇒⇩0 nat)) q) 0) 0 =
poly_subst (λy. monomial (a y) (0::'x ⇒⇩0 nat)) q" for q
by (intro poly_deg_zero_imp_monomial poly_deg_poly_subst_eq_zeroI) simp
show ?thesis unfolding poly_eval_focus
by (simp add: poly_eval_def poly_subst_poly_subst if_distrib poly_subst_monomial subst_pp_single eq
cong: if_cong)
qed
lemma indets_poly_eval_focus_subset:
"indets (poly_eval a (focus X p)) ⊆ ⋃ (indets ` a ` X) ∪ (indets p - X)"
proof
fix x
assume "x ∈ indets (poly_eval a (focus X p))"
also have "… = indets (poly_subst (λx. if x ∈ X then a x else monomial 1 (Poly_Mapping.single x 1)) p)"
(is "_ = indets (poly_subst ?f _)") by (simp only: poly_eval_focus)
finally obtain y where "y ∈ indets p" and "x ∈ indets (?f y)" by (rule in_indets_poly_substE)
from this(2) have "(x ∉ X ∧ x = y) ∨ (y ∈ X ∧ x ∈ indets (a y))"
by (simp add: indets_monomial split: if_split_asm)
thus "x ∈ ⋃ (indets ` a ` X) ∪ (indets p - X)"
proof (elim disjE conjE)
assume "x ∉ X" and "x = y"
with ‹y ∈ indets p› have "x ∈ indets p - X" by simp
thus ?thesis ..
next
assume "y ∈ X" and "x ∈ indets (a y)"
hence "x ∈ ⋃ (indets ` a ` X)" by blast
thus ?thesis ..
qed
qed
lemma lookup_poly_eval_focus:
"lookup (poly_eval (λx. monomial (a x) 0) (focus X p)) t = poly_eval a (lookup (focus (- X) p) t)"
proof -
let ?f = "λx. if x ∈ X then monomial (a x) 0 else monomial 1 (Poly_Mapping.single x 1)"
have eq: "subst_pp ?f s = monomial (∏x∈keys s ∩ X. a x ^ lookup s x) (except s X)" for s
proof -
have "subst_pp ?f s = (∏x∈(keys s ∩ X) ∪ (keys s - X). ?f x ^ lookup s x)"
unfolding subst_pp_def by (rule prod.cong) blast+
also have "… = (∏x∈keys s ∩ X. ?f x ^ lookup s x) * (∏x∈keys s - X. ?f x ^ lookup s x)"
by (rule prod.union_disjoint) auto
also have "… = monomial (∏x∈keys s ∩ X. a x ^ lookup s x)
(∑x∈keys s - X. Poly_Mapping.single x (lookup s x))"
by (simp add: monomial_power_map_scale times_monomial_monomial flip: punit.monomial_prod_sum)
also have "(∑x∈keys s - X. Poly_Mapping.single x (lookup s x)) = except s X"
by (metis (mono_tags, lifting) DiffD2 keys_except lookup_except_eq_idI
poly_mapping_sum_monomials sum.cong)
finally show ?thesis .
qed
show ?thesis
by (simp add: poly_eval_focus poly_subst_def lookup_sum eq flip: punit.map_scale_eq_monom_mult)
(simp add: focus_def lookup_sum poly_eval_sum lookup_single when_distrib poly_eval_monomial
keys_except lookup_except_when)
qed
lemma keys_poly_eval_focus_subset:
"keys (poly_eval (λx. monomial (a x) 0) (focus X p)) ⊆ (λt. except t X) ` keys p"
proof
fix t
assume "t ∈ keys (poly_eval (λx. monomial (a x) 0) (focus X p))"
hence "lookup (poly_eval (λx. monomial (a x) 0) (focus X p)) t ≠ 0" by (simp add: in_keys_iff)
hence "poly_eval a (lookup (focus (- X) p) t) ≠ 0" by (simp add: lookup_poly_eval_focus)
hence "t ∈ keys (focus (- X) p)" by (auto simp flip: lookup_not_eq_zero_eq_in_keys)
thus "t ∈ (λt. except t X) ` keys p" by (simp add: keys_focus)
qed
lemma poly_eval_focus_in_Polys:
assumes "p ∈ P[X]"
shows "poly_eval (λx. monomial (a x) 0) (focus Y p) ∈ P[X - Y]"
proof (rule PolysI_alt)
have "indets (poly_eval (λx. monomial (a x) 0) (focus Y p)) ⊆
⋃ (indets ` (λx. monomial (a x) 0) ` Y) ∪ (indets p - Y)"
by (fact indets_poly_eval_focus_subset)
also have "… = indets p - Y" by simp
also from assms have "… ⊆ X - Y" by (auto dest: PolysD)
finally show "indets (poly_eval (λx. monomial (a x) 0) (focus Y p)) ⊆ X - Y" .
qed
lemma image_poly_eval_focus_ideal:
"poly_eval (λx. monomial (a x) 0) ` focus X ` ideal F =
ideal (poly_eval (λx. monomial (a x) 0) ` focus X ` F) ∩
(P[- X]::(('x ⇒⇩0 nat) ⇒⇩0 'a::comm_ring_1) set)"
proof -
let ?h = "λf. poly_eval (λx. monomial (a x) 0) (focus X f)"
have h_id: "?h p = p" if "p ∈ P[- X]" for p
proof -
from that have "focus X p ∈ P[- X ∩ X]" by (rule focus_in_Polys')
also have "… = P[{}]" by simp
finally obtain c where eq: "focus X p = monomial c 0" unfolding Polys_empty ..
hence "flatten (focus X p) = flatten (monomial c 0)" by (rule arg_cong)
hence "c = p" by (simp add: flatten_monomial)
thus "?h p = p" by (simp add: eq poly_eval_monomial)
qed
have rng: "range ?h = P[- X]"
proof (intro subset_antisym subsetI, elim rangeE)
fix b f
assume b: "b = ?h f"
have "?h f ∈ P[UNIV - X]" by (rule poly_eval_focus_in_Polys) simp
thus "b ∈ P[- X]" by (simp add: b Compl_eq_Diff_UNIV)
next
fix p :: "('x ⇒⇩0 nat) ⇒⇩0 'a"
assume "p ∈ P[- X]"
hence "?h p = p" by (rule h_id)
hence "p = ?h p" by (rule sym)
thus "p ∈ range ?h" by (rule range_eqI)
qed
have "poly_eval (λx. monomial (a x) 0) ` focus X ` ideal F = ?h ` ideal F" by (fact image_image)
also have "… = ideal (?h ` F) ∩ range ?h"
proof (rule image_ideal_eq_Int)
fix p
have "?h p ∈ range ?h" by (fact rangeI)
also have "… = P[- X]" by fact
finally show "?h (?h p) = ?h p" by (rule h_id)
qed (simp_all only: focus_plus poly_eval_plus focus_times poly_eval_times)
also have "… = ideal (poly_eval (λx. monomial (a x) 0) ` focus X ` F) ∩ P[- X]"
by (simp only: image_image rng)
finally show ?thesis .
qed
subsection ‹Locale @{term pm_powerprod}›
lemma varnum_eq_zero_iff: "varnum X t = 0 ⟷ t ∈ .[X]"
by (auto simp: varnum_def PPs_def)
lemma dgrad_set_varnum: "dgrad_set (varnum X) 0 = .[X]"
by (simp add: dgrad_set_def PPs_def varnum_eq_zero_iff)
context ordered_powerprod
begin
abbreviation "lcf ≡ punit.lc"
abbreviation "tcf ≡ punit.tc"
abbreviation "lpp ≡ punit.lt"
abbreviation "tpp ≡ punit.tt"
end
locale pm_powerprod =
ordered_powerprod ord ord_strict
for ord::"('x::{countable,linorder} ⇒⇩0 nat) ⇒ ('x ⇒⇩0 nat) ⇒ bool" (infixl "≼" 50)
and ord_strict (infixl "≺" 50)
begin
sublocale gd_powerprod ..
lemma PPs_closed_lpp:
assumes "p ∈ P[X]"
shows "lpp p ∈ .[X]"
proof (cases "p = 0")
case True
thus ?thesis by (simp add: zero_in_PPs)
next
case False
hence "lpp p ∈ keys p" by (rule punit.lt_in_keys)
also from assms have "… ⊆ .[X]" by (rule PolysD)
finally show ?thesis .
qed
lemma PPs_closed_tpp:
assumes "p ∈ P[X]"
shows "tpp p ∈ .[X]"
proof (cases "p = 0")
case True
thus ?thesis by (simp add: zero_in_PPs)
next
case False
hence "tpp p ∈ keys p" by (rule punit.tt_in_keys)
also from assms have "… ⊆ .[X]" by (rule PolysD)
finally show ?thesis .
qed
corollary PPs_closed_image_lpp: "F ⊆ P[X] ⟹ lpp ` F ⊆ .[X]"
by (auto intro: PPs_closed_lpp)
corollary PPs_closed_image_tpp: "F ⊆ P[X] ⟹ tpp ` F ⊆ .[X]"
by (auto intro: PPs_closed_tpp)
lemma hom_component_lpp:
assumes "p ≠ 0"
shows "hom_component p (deg_pm (lpp p)) ≠ 0" (is "?p ≠ 0")
and "lpp (hom_component p (deg_pm (lpp p))) = lpp p"
proof -
from assms have "lpp p ∈ keys p" by (rule punit.lt_in_keys)
hence *: "lpp p ∈ keys ?p" by (simp add: keys_hom_component)
thus "?p ≠ 0" by auto
from * show "lpp ?p = lpp p"
proof (rule punit.lt_eqI_keys)
fix t
assume "t ∈ keys ?p"
hence "t ∈ keys p" by (simp add: keys_hom_component)
thus "t ≼ lpp p" by (rule punit.lt_max_keys)
qed
qed
definition is_hom_ord :: "'x ⇒ bool"
where "is_hom_ord x ⟷ (∀s t. deg_pm s = deg_pm t ⟶ (s ≼ t ⟷ except s {x} ≼ except t {x}))"
lemma is_hom_ordD: "is_hom_ord x ⟹ deg_pm s = deg_pm t ⟹ s ≼ t ⟷ except s {x} ≼ except t {x}"
by (simp add: is_hom_ord_def)
lemma dgrad_p_set_varnum: "punit.dgrad_p_set (varnum X) 0 = P[X]"
by (simp add: punit.dgrad_p_set_def dgrad_set_varnum Polys_def)
end
text ‹We must create a copy of @{locale pm_powerprod} to avoid infinite chains of interpretations.›
instantiation option :: (linorder) linorder
begin
fun less_eq_option :: "'a option ⇒ 'a option ⇒ bool" where
"less_eq_option None _ = True" |
"less_eq_option (Some x) None = False" |
"less_eq_option (Some x) (Some y) = (x ≤ y)"
definition less_option :: "'a option ⇒ 'a option ⇒ bool"
where "less_option x y ⟷ x ≤ y ∧ ¬ y ≤ x"
instance proof
fix x :: "'a option"
show "x ≤ x" using less_eq_option.elims(3) by fastforce
qed (auto simp: less_option_def elim!: less_eq_option.elims)
end
locale extended_ord_pm_powerprod = pm_powerprod
begin
definition extended_ord :: "('a option ⇒⇩0 nat) ⇒ ('a option ⇒⇩0 nat) ⇒ bool"
where "extended_ord s t ⟷ (restrict_indets_pp s ≺ restrict_indets_pp t ∨
(restrict_indets_pp s = restrict_indets_pp t ∧ lookup s None ≤ lookup t None))"
definition extended_ord_strict :: "('a option ⇒⇩0 nat) ⇒ ('a option ⇒⇩0 nat) ⇒ bool"
where "extended_ord_strict s t ⟷ (restrict_indets_pp s ≺ restrict_indets_pp t ∨
(restrict_indets_pp s = restrict_indets_pp t ∧ lookup s None < lookup t None))"
sublocale extended_ord: pm_powerprod extended_ord extended_ord_strict
proof -
have 1: "s = t" if "lookup s None = lookup t None" and "restrict_indets_pp s = restrict_indets_pp t"
for s t :: "'a option ⇒⇩0 nat"
proof (rule poly_mapping_eqI)
fix y
show "lookup s y = lookup t y"
proof (cases y)
case None
with that(1) show ?thesis by simp
next
case y: (Some z)
have "lookup s y = lookup (restrict_indets_pp s) z" by (simp only: lookup_restrict_indets_pp y)
also have "… = lookup (restrict_indets_pp t) z" by (simp only: that(2))
also have "… = lookup t y" by (simp only: lookup_restrict_indets_pp y)
finally show ?thesis .
qed
qed
have 2: "0 ≺ t" if "t ≠ 0" for t::"'a ⇒⇩0 nat"
using that zero_min by (rule ordered_powerprod_lin.dual_order.not_eq_order_implies_strict)
show "pm_powerprod extended_ord extended_ord_strict"
by standard (auto simp: extended_ord_def extended_ord_strict_def restrict_indets_pp_plus lookup_add 1
dest: plus_monotone_strict 2)
qed
lemma extended_ord_is_hom_ord: "extended_ord.is_hom_ord None"
by (auto simp add: extended_ord_def lookup_restrict_indets_pp lookup_except extended_ord.is_hom_ord_def
simp flip: deg_pm_restrict_indets_pp)
end
end
Theory MPoly_Type_Univariate
theory MPoly_Type_Univariate
imports
More_MPoly_Type
"HOL-Computational_Algebra.Polynomial"
begin
text ‹This file connects univariate MPolys to the theory of univariate polynomials from
@{theory "HOL-Computational_Algebra.Polynomial"}.›
definition poly_to_mpoly::"nat ⇒ 'a::comm_monoid_add poly ⇒ 'a mpoly"
where "poly_to_mpoly v p = MPoly (Abs_poly_mapping (λm. (coeff p (Poly_Mapping.lookup m v)) when Poly_Mapping.keys m ⊆ {v}))"
lemma poly_to_mpoly_finite: "finite {m::nat ⇒⇩0 nat. (coeff p (Poly_Mapping.lookup m v) when Poly_Mapping.keys m ⊆ {v}) ≠ 0}" (is "finite ?M")
proof -
have "?M ⊆ Poly_Mapping.single v ` {x. Polynomial.coeff p x ≠ 0}"
proof
fix m assume "m ∈ ?M"
then have "⋀v'. v'≠v ⟹ Poly_Mapping.lookup m v' = 0" by (fastforce simp add: in_keys_iff)
then have "m = Poly_Mapping.single v (Poly_Mapping.lookup m v)"
using Poly_Mapping.poly_mapping_eqI by (metis (full_types) lookup_single_eq lookup_single_not_eq)
then show "m ∈ (Poly_Mapping.single v) ` {x. Polynomial.coeff p x ≠ 0}" using ‹m ∈ ?M› by auto
qed
then show ?thesis using finite_surj[OF MOST_coeff_eq_0[unfolded eventually_cofinite]] by blast
qed
lemma coeff_poly_to_mpoly: "MPoly_Type.coeff (poly_to_mpoly v p) (Poly_Mapping.single v k) = Polynomial.coeff p k"
unfolding poly_to_mpoly_def coeff_def MPoly_inverse[OF Set.UNIV_I] lookup_Abs_poly_mapping[OF poly_to_mpoly_finite]
using empty_subsetI keys_single lookup_single order_refl when_simps(1) by simp
definition mpoly_to_poly::"nat ⇒ 'a::comm_monoid_add mpoly ⇒ 'a poly"
where "mpoly_to_poly v p = Abs_poly (λk. MPoly_Type.coeff p (Poly_Mapping.single v k))"
lemma coeff_mpoly_to_poly[simp]: "Polynomial.coeff (mpoly_to_poly v p) k = MPoly_Type.coeff p (Poly_Mapping.single v k)"
proof -
have 0:"Poly_Mapping.single v ` {x. Poly_Mapping.lookup (mapping_of p) (Poly_Mapping.single v x) ≠ 0}
⊆ {k. Poly_Mapping.lookup (mapping_of p) k ≠ 0}"
by auto
have "∀⇩∞ k. MPoly_Type.coeff p (Poly_Mapping.single v k) = 0" unfolding coeff_def eventually_cofinite
using finite_imageD[OF finite_subset[OF 0 Poly_Mapping.finite_lookup]] inj_single by (metis inj_eq inj_onI)
then show ?thesis
unfolding mpoly_to_poly_def by (simp add: Abs_poly_inverse)
qed
lemma mpoly_to_poly_inverse:
assumes "vars p ⊆ {v}"
shows "poly_to_mpoly v (mpoly_to_poly v p) = p"
proof -
define f where "f = (λm. Polynomial.coeff (mpoly_to_poly v p) (Poly_Mapping.lookup m v) when Poly_Mapping.keys m ⊆ {v})"
have "finite {m. f m ≠ 0}" unfolding f_def using poly_to_mpoly_finite by blast
have "Abs_poly_mapping f = mapping_of p"
proof (rule "Poly_Mapping.poly_mapping_eqI")
fix m
show "Poly_Mapping.lookup (Abs_poly_mapping f) m = Poly_Mapping.lookup (mapping_of p) m"
proof (cases "Poly_Mapping.keys m ⊆ {v}")
assume "Poly_Mapping.keys m ⊆ {v}"
then show ?thesis unfolding "Poly_Mapping.lookup_Abs_poly_mapping"[OF ‹finite {m. f m ≠ 0}›] unfolding f_def
unfolding coeff_mpoly_to_poly coeff_def using when_simps(1) apply simp
using keys_single lookup_not_eq_zero_eq_in_keys lookup_single_eq
lookup_single_not_eq poly_mapping_eqI subset_singletonD
by (metis (no_types, lifting) aux lookup_eq_zero_in_keys_contradict)
next
assume "¬Poly_Mapping.keys m ⊆ {v}"
then show ?thesis unfolding "Poly_Mapping.lookup_Abs_poly_mapping"[OF ‹finite {m. f m ≠ 0}›] unfolding f_def
using ‹vars p ⊆ {v}› unfolding vars_def by (metis (no_types, lifting) UN_I lookup_not_eq_zero_eq_in_keys subsetCE subsetI when_def)
qed
qed
then show ?thesis
unfolding poly_to_mpoly_def f_def by (simp add: mapping_of_inverse)
qed
lemma poly_to_mpoly_inverse: "mpoly_to_poly v (poly_to_mpoly v p) = p"
unfolding mpoly_to_poly_def coeff_poly_to_mpoly by (simp add: coeff_inverse)
lemma poly_to_mpoly0: "poly_to_mpoly v 0 = 0"
proof -
have "⋀m. (Polynomial.coeff 0 (Poly_Mapping.lookup m v) when Poly_Mapping.keys m ⊆ {v}) = 0" by simp
have "Abs_poly_mapping (λm. Polynomial.coeff 0 (Poly_Mapping.lookup m v) when Poly_Mapping.keys m ⊆ {v}) = 0"
apply (rule Poly_Mapping.poly_mapping_eqI) unfolding lookup_Abs_poly_mapping[OF poly_to_mpoly_finite] by auto
then show ?thesis using poly_to_mpoly_def zero_mpoly.abs_eq by (metis (no_types))
qed
lemma mpoly_to_poly_add: "mpoly_to_poly v (p1 + p2) = mpoly_to_poly v p1 + mpoly_to_poly v p2"
unfolding Polynomial.plus_poly.abs_eq More_MPoly_Type.coeff_add coeff_mpoly_to_poly
using mpoly_to_poly_def by auto
lemma poly_eq_insertion:
assumes "vars p ⊆ {v}"
shows "poly (mpoly_to_poly v p) x = insertion (λv. x) p"
using assms proof (induction p rule:mpoly_induct)
case (monom m a)
then show ?case
proof (cases "a=0")
case True
then show ?thesis
by (metis MPoly_Type.monom.abs_eq insertion_zero monom_zero poly_0 poly_to_mpoly0 poly_to_mpoly_inverse single_zero)
next
case False
then have "Poly_Mapping.keys m ⊆ {v}" using monom unfolding vars_def MPoly_Type.mapping_of_monom keys_single by simp
then have "⋀v'. v'≠v ⟹ Poly_Mapping.lookup m v' = 0" unfolding vars_def by (auto simp: in_keys_iff)
then have "m = Poly_Mapping.single v (Poly_Mapping.lookup m v)"
by (metis lookup_single_eq lookup_single_not_eq poly_mapping_eqI)
then have 0:"insertion (λv. x) (MPoly_Type.monom m a) = a * x ^ (Poly_Mapping.lookup m v)"
using insertion_single by metis
have "⋀k. Poly_Mapping.single v k = m ⟷ Poly_Mapping.lookup m v = k"
using ‹m = Poly_Mapping.single v (Poly_Mapping.lookup m v)› by auto
then have "monom a (Poly_Mapping.lookup m v) = (Abs_poly (λk. if Poly_Mapping.single v k = m then a else 0))"
by (simp add: Polynomial.monom.abs_eq)
then show ?thesis unfolding mpoly_to_poly_def More_MPoly_Type.coeff_monom 0 when_def by (metis poly_monom)
qed
next
case (sum p1 p2 m a)
then have "poly (mpoly_to_poly v p1) x = insertion (λv. x) p1"
"poly (mpoly_to_poly v p2) x = insertion (λv. x) p2"
by (simp_all add: vars_add_monom)
then show ?case unfolding insertion_add mpoly_to_poly_add by simp
qed
text ‹Using the new connection between MPoly and univariate polynomials, we can transfer:›
lemma univariate_mpoly_roots_finite:
fixes p::"'a::idom mpoly"
assumes "vars p ⊆ {v}" "p ≠ 0"
shows "finite {x. insertion (λv. x) p = 0}"
using poly_roots_finite[of "mpoly_to_poly v p", unfolded poly_eq_insertion[OF ‹vars p ⊆ {v}›]]
using assms(1) assms(2) mpoly_to_poly_inverse poly_to_mpoly0 by fastforce
end
Theory Polynomials
section ‹Polynomials›
theory Polynomials
imports
"Abstract-Rewriting.SN_Orders"
Matrix.Utility
begin
subsection ‹
Polynomials represented as trees
›
datatype (vars_tpoly: 'v, nums_tpoly: 'a)tpoly = PVar 'v | PNum 'a | PSum "('v,'a)tpoly list" | PMult "('v,'a)tpoly list"
type_synonym ('v,'a)assign = "'v ⇒ 'a"
primrec eval_tpoly :: "('v,'a::{monoid_add,monoid_mult})assign ⇒ ('v,'a)tpoly ⇒ 'a"
where "eval_tpoly α (PVar x) = α x"
| "eval_tpoly α (PNum a) = a"
| "eval_tpoly α (PSum ps) = sum_list (map (eval_tpoly α) ps)"
| "eval_tpoly α (PMult ps) = prod_list (map (eval_tpoly α) ps)"
subsection ‹Polynomials represented in normal form as lists of monomials›
text ‹
The internal representation of polynomials is a sum of products of monomials with coefficients
where all coefficients are non-zero, and all monomials are different
›
text ‹Definition of type ‹monom››
type_synonym 'v monom_list = "('v × nat)list"
text ‹
\begin{itemize}
\item $[(x,n),(y,m)]$ represent $x^n \cdot y^m$
\item invariants: all powers are $\geq 1$ and each variable occurs at most once \\
hence: $[(x,1),(y,2),(x,2)]$ will not occur, but $[(x,3),(y,2)]$;
$[(x,1),(y,0)]$ will not occur, but $[(x,1)]$
\end{itemize}
›
context linorder
begin
definition monom_inv :: "'a monom_list ⇒ bool" where
"monom_inv m ≡ (∀ (x,n) ∈ set m. 1 ≤ n) ∧ distinct (map fst m) ∧ sorted (map fst m)"
fun eval_monom_list :: "('a,'b :: comm_semiring_1)assign ⇒ ('a monom_list) ⇒ 'b" where
"eval_monom_list α [] = 1"
| "eval_monom_list α ((x,p) # m) = eval_monom_list α m * (α x)^p"
lemma eval_monom_list[simp]: "eval_monom_list α (m @ n) = eval_monom_list α m * eval_monom_list α n"
by (induct m, auto simp: field_simps)
definition sum_var_list :: "'a monom_list ⇒ 'a ⇒ nat" where
"sum_var_list m x ≡ sum_list (map (λ (y,c). if x = y then c else 0) m)"
lemma sum_var_list_not: "x ∉ fst ` set m ⟹ sum_var_list m x = 0"
unfolding sum_var_list_def by (induct m, auto)
text ‹
show that equality of monomials is equivalent to statement that
all variables occur with the same (accumulated) power;
afterwards properties like transitivity, etc. are easy to prove›
lemma monom_inv_Cons: assumes "monom_inv ((x,p) # m)"
and "y ≤ x" shows "y ∉ fst ` set m"
proof -
define M where "M = map fst m"
from assms[unfolded monom_inv_def]
have "distinct (x # map fst m)" "sorted (x # map fst m)" by auto
with assms(2) have "y ∉ set (map fst m)" unfolding M_def[symmetric]
by (induct M, auto)
thus ?thesis by auto
qed
lemma eq_monom_sum_var_list: assumes "monom_inv m" and "monom_inv n"
shows "(m = n) = (∀ x. sum_var_list m x = sum_var_list n x)" (is "?l = ?r")
using assms
proof (induct m arbitrary: n)
case Nil
show ?case
proof (cases n)
case (Cons yp nn)
obtain y p where yp: "yp = (y,p)" by (cases yp, auto)
with Cons Nil(2)[unfolded monom_inv_def] have p: "0 < p" by auto
show ?thesis by (simp add: Cons, rule exI[of _ y], simp add: sum_var_list_def yp p)
qed simp
next
case (Cons xp m)
obtain x p where xp: "xp = (x,p)" by (cases xp, auto)
with Cons(2) have p: "0 < p" and x: "x ∉ fst ` set m" and m: "monom_inv m" unfolding monom_inv_def
by (auto)
show ?case
proof (cases n)
case Nil
thus ?thesis by (auto simp: xp sum_var_list_def p intro!: exI[of _ x])
next
case n: (Cons yq n')
from Cons(3)[unfolded n] have n': "monom_inv n'" by (auto simp: monom_inv_def)
show ?thesis
proof (cases "yq = xp")
case True
show ?thesis unfolding n True using Cons(1)[OF m n'] by (auto simp: xp sum_var_list_def)
next
case False
obtain y q where yq: "yq = (y,q)" by force
from Cons(3)[unfolded n yq monom_inv_def] have q: "q > 0" by auto
define z where "z = min x y"
have zm: "z ∉ fst ` set m" using Cons(2) unfolding xp z_def
by (rule monom_inv_Cons, simp)
have zn': "z ∉ fst ` set n'" using Cons(3) unfolding n yq z_def
by (rule monom_inv_Cons, simp)
have smz: "sum_var_list (xp # m) z = sum_var_list [(x,p)] z"
using sum_var_list_not[OF zm] by (simp add: sum_var_list_def xp)
also have "… ≠ sum_var_list [(y,q)] z" using False unfolding xp yq
by (auto simp: sum_var_list_def z_def p q min_def)
also have "sum_var_list [(y,q)] z = sum_var_list n z"
using sum_var_list_not[OF zn'] by (simp add: sum_var_list_def n yq)
finally show ?thesis using False unfolding n by auto
qed
qed
qed
text ‹
equality of monomials is also a complete for several carriers, e.g. the naturals, integers, where $x^p = x^q$ implies $p = q$.
note that it is not complete for carriers like the Booleans where e.g. $x^{Suc(m)} = x^{Suc(n)}$ for all $n,m$.
›
abbreviation (input) monom_list_vars :: "'a monom_list ⇒ 'a set"
where "monom_list_vars m ≡ fst ` set m"
fun monom_mult_list :: "'a monom_list ⇒ 'a monom_list ⇒ 'a monom_list" where
"monom_mult_list [] n = n"
| "monom_mult_list ((x,p) # m) n = (case n of
Nil ⇒ (x,p) # m
| (y,q) # n' ⇒ if x = y then (x,p + q) # monom_mult_list m n' else
if x < y then (x,p) # monom_mult_list m n else (y,q) # monom_mult_list ((x,p) # m) n')"
lemma monom_list_mult_list_vars: "monom_list_vars (monom_mult_list m1 m2) = monom_list_vars m1 ∪ monom_list_vars m2"
by (induct m1 m2 rule: monom_mult_list.induct, auto split: list.splits)
lemma monom_mult_list_inv: "monom_inv m1 ⟹ monom_inv m2 ⟹ monom_inv (monom_mult_list m1 m2)"
proof (induct m1 m2 rule: monom_mult_list.induct)
case (2 x p m n')
note IH = 2(1-3)
note xpm = 2(4)
note n' = 2(5)
show ?case
proof (cases n')
case Nil
with xpm show ?thesis by auto
next
case (Cons yq n)
then obtain y q where id: "n' = ((y,q) # n)" by (cases yq, auto)
from xpm have m: "monom_inv m" and p: "p > 0" and x: "x ∉ fst ` set m"
and xm: "⋀ z. z ∈ fst ` set m ⟹ x ≤ z"
unfolding monom_inv_def by (auto)
from n'[unfolded id] have n: "monom_inv n" and q: "q > 0" and y: "y ∉ fst ` set n"
and yn: "⋀ z. z ∈ fst ` set n ⟹ y ≤ z"
unfolding monom_inv_def by (auto)
show ?thesis
proof (cases "x = y")
case True
hence res: "monom_mult_list ((x, p) # m) n' = (x, p + q) # monom_mult_list m n"
by (simp add: id)
from IH(1)[OF id refl True m n] have inv: "monom_inv (monom_mult_list m n)" by simp
show ?thesis unfolding res using inv p x y True xm yn
by (fastforce simp add: monom_inv_def monom_list_mult_list_vars)
next
case False
show ?thesis
proof (cases "x < y")
case True
hence res: "monom_mult_list ((x, p) # m) n' = (x,p) # monom_mult_list m n'"
by (auto simp add: id)
from IH(2)[OF id refl False True m n'] have inv: "monom_inv (monom_mult_list m n')" .
show ?thesis unfolding res using inv p x y True xm yn unfolding id
by (fastforce simp add: monom_inv_def monom_list_mult_list_vars)
next
case gt: False
with False have lt: "y < x" by auto
hence res: "monom_mult_list ((x, p) # m) n' = (y,q) # monom_mult_list ((x, p) # m) n"
using False by (auto simp add: id)
from lt have zm: "z ≤ x ⟹ (z,b) ∉ set m" for z b using xm[of z] x by force
from zm[of y] lt have ym: "(y,b) ∉ set m" for b by auto
from yn have yn': "(a, b) ∈ set n ⟹ y ≤ a" for a b by force
from IH(3)[OF id refl False gt xpm n] have inv: "monom_inv (monom_mult_list ((x, p) # m) n)" .
define xpm where "xpm = ((x,p) # m)"
have xpm': "fst ` set xpm = insert x (fst ` set m)" unfolding xpm_def by auto
show ?thesis unfolding res using inv p q x y False gt ym lt xm yn' zm xpm' unfolding id xpm_def[symmetric]
by (auto simp add: monom_inv_def monom_list_mult_list_vars)
qed
qed
qed
qed auto
lemma monom_inv_ConsD: "monom_inv (x # xs) ⟹ monom_inv xs"
by (auto simp: monom_inv_def)
lemma sum_var_list_monom_mult_list: "sum_var_list (monom_mult_list m n) x = sum_var_list m x + sum_var_list n x"
proof (induct m n rule: monom_mult_list.induct)
case (2 x p m n)
thus ?case by (cases n; cases "hd n", auto split: if_splits simp: sum_var_list_def)
qed (auto simp: sum_var_list_def)
lemma monom_mult_list_inj: assumes m: "monom_inv m" and m1: "monom_inv m1" and m2: "monom_inv m2"
and eq: "monom_mult_list m m1 = monom_mult_list m m2"
shows "m1 = m2"
proof -
from eq sum_var_list_monom_mult_list[of m] show ?thesis
by (auto simp: eq_monom_sum_var_list[OF m1 m2] eq_monom_sum_var_list[OF monom_mult_list_inv[OF m m1] monom_mult_list_inv[OF m m2]])
qed
lemma monom_mult_list[simp]: "eval_monom_list α (monom_mult_list m n) = eval_monom_list α m * eval_monom_list α n"
by (induct m n rule: monom_mult_list.induct, auto split: list.splits prod.splits simp: field_simps power_add)
end
declare monom_mult_list.simps[simp del]
typedef (overloaded) 'v monom = "Collect (monom_inv :: 'v :: linorder monom_list ⇒ bool)"
by (rule exI[of _ Nil], auto simp: monom_inv_def)
setup_lifting type_definition_monom
lift_definition eval_monom :: "('v :: linorder,'a :: comm_semiring_1)assign ⇒ 'v monom ⇒ 'a"
is eval_monom_list .
lift_definition sum_var :: "'v :: linorder monom ⇒ 'v ⇒ nat" is sum_var_list .
instantiation monom :: (linorder) comm_monoid_mult
begin
lift_definition times_monom :: "'a monom ⇒ 'a monom ⇒ 'a monom" is monom_mult_list
using monom_mult_list_inv by auto
lift_definition one_monom :: "'a monom" is Nil
by (auto simp: monom_inv_def)
instance
proof
fix a b c :: "'a monom"
show "a * b * c = a * (b * c)"
by (transfer, auto simp: eq_monom_sum_var_list monom_mult_list_inv sum_var_list_monom_mult_list)
show "a * b = b * a"
by (transfer, auto simp: eq_monom_sum_var_list monom_mult_list_inv sum_var_list_monom_mult_list)
show "1 * a = a"
by (transfer, auto simp: eq_monom_sum_var_list monom_mult_list_inv sum_var_list_monom_mult_list monom_mult_list.simps)
qed
end
lemma eq_monom_sum_var: "m = n ⟷ (∀ x. sum_var m x = sum_var n x)"
by (transfer, auto simp: eq_monom_sum_var_list)
lemma eval_monom_mult[simp]: "eval_monom α (m * n) = eval_monom α m * eval_monom α n"
by (transfer, rule monom_mult_list)
lemma sum_var_monom_mult: "sum_var (m * n) x = sum_var m x + sum_var n x"
by (transfer, rule sum_var_list_monom_mult_list)
lemma monom_mult_inj: fixes m1 :: "_ monom"
shows "m * m1 = m * m2 ⟹ m1 = m2"
by (transfer, rule monom_mult_list_inj, auto)
lemma one_monom_inv_sum_var_inv[simp]: "sum_var 1 x = 0"
by (transfer, auto simp: sum_var_list_def)
lemma eval_monom_1[simp]: "eval_monom α 1 = 1"
by (transfer, auto)
lift_definition var_monom :: "'v :: linorder ⇒ 'v monom" is "λ x. [(x,1)]"
by (auto simp: monom_inv_def)
lemma var_monom_1[simp]: "var_monom x ≠ 1"
by (transfer, auto)
lemma eval_var_monom[simp]: "eval_monom α (var_monom x) = α x"
by (transfer, auto)
lemma sum_var_monom_var: "sum_var (var_monom x) y = (if x = y then 1 else 0)"
by (transfer, auto simp: sum_var_list_def)
instantiation monom :: ("{equal,linorder}")equal
begin
lift_definition equal_monom :: "'a monom ⇒ 'a monom ⇒ bool" is "(=)" .
instance by (standard, transfer, auto)
end
text ‹
Polynomials are represented with as sum of monomials multiplied by some coefficient
›
type_synonym ('v,'a)poly = "('v monom × 'a)list"
text ‹
The polynomials we construct satisfy the following invariants:
\begin{itemize}
\item all coefficients are non-zero
\item the monomial list is distinct
\end{itemize}
›
definition poly_inv :: "('v,'a :: zero)poly ⇒ bool"
where "poly_inv p ≡ (∀ c ∈ snd ` set p. c ≠ 0) ∧ distinct (map fst p)"
abbreviation eval_monomc where "eval_monomc α mc ≡ eval_monom α (fst mc) * (snd mc)"
primrec eval_poly :: "('v :: linorder, 'a :: comm_semiring_1)assign ⇒ ('v,'a)poly ⇒ 'a" where
"eval_poly α [] = 0"
| "eval_poly α (mc # p) = eval_monomc α mc + eval_poly α p"
definition poly_const :: "'a :: zero ⇒ ('v :: linorder,'a)poly" where
"poly_const a = (if a = 0 then [] else [(1,a)])"
lemma poly_const[simp]: "eval_poly α (poly_const a) = a"
unfolding poly_const_def by auto
lemma poly_const_inv: "poly_inv (poly_const a)"
unfolding poly_const_def poly_inv_def by auto
fun poly_add :: "('v,'a)poly ⇒ ('v,'a :: semiring_0)poly ⇒ ('v,'a)poly" where
"poly_add [] q = q"
| "poly_add ((m,c) # p) q = (case List.extract (λ mc. fst mc = m) q of
None ⇒ (m,c) # poly_add p q
| Some (q1,(_,d),q2) ⇒ if (c+d = 0) then poly_add p (q1 @ q2) else (m,c+d) # poly_add p (q1 @ q2))"
lemma eval_poly_append[simp]: "eval_poly α (mc1 @ mc2) = eval_poly α mc1 + eval_poly α mc2"
by (induct mc1, auto simp: field_simps)
abbreviation poly_monoms :: "('v,'a)poly ⇒ 'v monom set"
where "poly_monoms p ≡ fst ` set p"
lemma poly_add_monoms: "poly_monoms (poly_add p1 p2) ⊆ poly_monoms p1 ∪ poly_monoms p2"
proof (induct p1 arbitrary: p2)
case (Cons mc p)
obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
hence m: "m ∈ poly_monoms (mc # p1)" by auto
show ?case
proof (cases "List.extract (λ nd. fst nd = m) p2")
case None
with Cons m show ?thesis by (auto simp: mc)
next
case (Some res)
obtain q1 md q2 where res: "res = (q1,md,q2)" by (cases res, auto)
from extract_SomeE[OF Some[simplified res]] res obtain d where q: "p2 = q1 @ (m,d) # q2" and res: "res = (q1,(m,d),q2)" by (cases md, auto)
show ?thesis
by (simp add: mc Some res, rule subset_trans[OF Cons[of "q1 @ q2"]], auto simp: q)
qed
qed simp
lemma poly_add_inv: "poly_inv p ⟹ poly_inv q ⟹ poly_inv (poly_add p q)"
proof (induct p arbitrary: q)
case (Cons mc p)
obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
with Cons(2) have p: "poly_inv p" and c: "c ≠ 0" and mp: "∀ mm ∈ fst ` set p. (¬ mm = m)" unfolding poly_inv_def by auto
show ?case
proof (cases "List.extract (λ mc. fst mc = m) q")
case None
hence mq: "∀ mm ∈ fst ` set q. ¬ mm = m" by (auto simp: extract_None_iff)
{
fix mm
assume "mm ∈ fst ` set (poly_add p q)"
then obtain dd where "(mm,dd) ∈ set (poly_add p q)" by auto
with poly_add_monoms have "mm ∈ poly_monoms p ∨ mm ∈ poly_monoms q" by force
hence "¬ mm = m" using mp mq by auto
} note main = this
show ?thesis using Cons(1)[OF p Cons(3)] unfolding poly_inv_def using main by (auto simp add: None mc c)
next
case (Some res)
obtain q1 md q2 where res: "res = (q1,md,q2)" by (cases res, auto)
from extract_SomeE[OF Some[simplified res]] res obtain d where q: "q = q1 @ (m,d) # q2" and res: "res = (q1,(m,d),q2)" by (cases md, auto)
from q Cons(3) have q1q2: "poly_inv (q1 @ q2)" unfolding poly_inv_def by auto
from Cons(1)[OF p q1q2] have main1: "poly_inv (poly_add p (q1 @ q2))" .
{
fix mm
assume "mm ∈ fst ` set (poly_add p (q1 @ q2))"
then obtain dd where "(mm,dd) ∈ set (poly_add p (q1 @ q2))" by auto
with poly_add_monoms have "mm ∈ poly_monoms p ∨ mm ∈ poly_monoms (q1 @ q2)" by force
hence "mm ≠ m"
proof
assume "mm ∈ poly_monoms p"
thus ?thesis using mp by auto
next
assume member: "mm ∈ poly_monoms (q1 @ q2)"
from member have "mm ∈ poly_monoms q1 ∨ mm ∈ poly_monoms q2" by auto
thus "mm ≠ m"
proof
assume "mm ∈ poly_monoms q2"
with Cons(3)[simplified q]
show ?thesis unfolding poly_inv_def by auto
next
assume "mm ∈ poly_monoms q1"
with Cons(3)[simplified q]
show ?thesis unfolding poly_inv_def by auto
qed
qed
} note main2 = this
show ?thesis using main1[unfolded poly_inv_def] main2
by (auto simp: poly_inv_def mc Some res)
qed
qed simp
lemma poly_add[simp]: "eval_poly α (poly_add p q) = eval_poly α p + eval_poly α q"
proof (induct p arbitrary: q)
case (Cons mc p)
obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
show ?case
proof (cases "List.extract (λ mc. fst mc = m) q")
case None
show ?thesis by (simp add: Cons[of q] mc None field_simps)
next
case (Some res)
obtain q1 md q2 where res: "res = (q1,md,q2)" by (cases res, auto)
from extract_SomeE[OF Some[simplified res]] res obtain d where q: "q = q1 @ (m,d) # q2" and res: "res = (q1,(m,d),q2)" by (cases md, auto)
{
fix x
assume c: "c + d = 0"
have "c * x + d * x = (c + d) * x" by (auto simp: field_simps)
also have "… = 0 * x" by (simp only: c)
finally have "c * x + d * x = 0" by simp
} note id = this
show ?thesis
by (simp add: Cons[of "q1 @ q2"] mc Some res, simp only: q, simp add: field_simps, auto simp: field_simps id)
qed
qed simp
declare poly_add.simps[simp del]
fun monom_mult_poly :: "('v :: linorder monom × 'a) ⇒ ('v,'a :: semiring_0)poly ⇒ ('v,'a)poly" where
"monom_mult_poly _ [] = []"
| "monom_mult_poly (m,c) ((m',d) # p) = (if c * d = 0 then monom_mult_poly (m,c) p else (m * m', c * d) # monom_mult_poly (m,c) p)"
lemma monom_mult_poly_inv: "poly_inv p ⟹ poly_inv (monom_mult_poly (m,c) p)"
proof (induct p)
case Nil thus ?case by (simp add: poly_inv_def)
next
case (Cons md p)
obtain m' d where md: "md = (m',d)" by (cases md, auto)
with Cons(2) have p: "poly_inv p" unfolding poly_inv_def by auto
from Cons(1)[OF p] have prod: "poly_inv (monom_mult_poly (m,c) p)" .
{
fix mm
assume "mm ∈ fst ` set (monom_mult_poly (m,c) p)"
and two: "mm = m * m'"
then obtain dd where one: "(mm,dd) ∈ set (monom_mult_poly (m,c) p)" by auto
have "poly_monoms (monom_mult_poly (m,c) p) ⊆ (*) m ` poly_monoms p"
proof (induct p, simp)
case (Cons md p)
thus ?case
by (cases md, auto)
qed
with one have "mm ∈ (*) m ` poly_monoms p" by force
then obtain mmm where mmm: "mmm ∈ poly_monoms p" and mm: "mm = m * mmm" by blast
from Cons(2)[simplified md] mmm have not1: "¬ mmm = m'" unfolding poly_inv_def by auto
from mm two have "m * mmm = m * m'" by simp
from monom_mult_inj[OF this] not1
have False by simp
}
thus ?case
by (simp add: md prod, intro impI, auto simp: poly_inv_def prod[simplified poly_inv_def])
qed
lemma monom_mult_poly[simp]: "eval_poly α (monom_mult_poly mc p) = eval_monomc α mc * eval_poly α p"
proof (cases mc)
case (Pair m c)
show ?thesis
proof (simp add: Pair, induct p)
case (Cons nd q)
obtain n d where nd: "nd = (n,d)" by (cases nd, auto)
show ?case
proof (cases "c * d = 0")
case False
thus ?thesis by (simp add: nd Cons field_simps)
next
case True
let ?l = "c * (d * (eval_monom α m * eval_monom α n))"
have "?l = (c * d) * (eval_monom α m * eval_monom α n)"
by (simp only: field_simps)
also have "… = 0" by (simp only: True, simp add: field_simps)
finally have l: "?l = 0" .
show ?thesis
by (simp add: nd Cons True, simp add: field_simps l)
qed
qed simp
qed
declare monom_mult_poly.simps[simp del]
definition poly_minus :: "('v :: linorder,'a :: ring_1)poly ⇒ ('v,'a)poly ⇒ ('v,'a)poly" where
"poly_minus f g = poly_add f (monom_mult_poly (1,-1) g)"
lemma poly_minus[simp]: "eval_poly α (poly_minus f g) = eval_poly α f - eval_poly α g"
unfolding poly_minus_def by simp
lemma poly_minus_inv: "poly_inv f ⟹ poly_inv g ⟹ poly_inv (poly_minus f g)"
unfolding poly_minus_def by (intro poly_add_inv monom_mult_poly_inv)
fun poly_mult :: "('v :: linorder, 'a :: semiring_0)poly ⇒ ('v,'a)poly ⇒ ('v,'a)poly" where
"poly_mult [] q = []"
| "poly_mult (mc # p) q = poly_add (monom_mult_poly mc q) (poly_mult p q)"
lemma poly_mult_inv: assumes p: "poly_inv p" and q: "poly_inv q"
shows "poly_inv (poly_mult p q)"
using p
proof (induct p)
case Nil thus ?case by (simp add: poly_inv_def)
next
case (Cons mc p)
obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
with Cons(2) have p: "poly_inv p" unfolding poly_inv_def by auto
show ?case
by (simp add: mc, rule poly_add_inv[OF monom_mult_poly_inv[OF q] Cons(1)[OF p]])
qed
lemma poly_mult[simp]: "eval_poly α (poly_mult p q) = eval_poly α p * eval_poly α q"
by (induct p, auto simp: field_simps)
declare poly_mult.simps[simp del]
definition zero_poly :: "('v,'a)poly"
where "zero_poly ≡ []"
lemma zero_poly_inv: "poly_inv zero_poly" unfolding zero_poly_def poly_inv_def by auto
definition one_poly :: "('v :: linorder,'a :: semiring_1)poly" where
"one_poly ≡ [(1,1)]"
lemma one_poly_inv: "poly_inv one_poly" unfolding one_poly_def poly_inv_def monom_inv_def by auto
lemma poly_one[simp]: "eval_poly α one_poly = 1"
unfolding one_poly_def by simp
lemma poly_zero_add: "poly_add zero_poly p = p" unfolding zero_poly_def using poly_add.simps by auto
lemma poly_zero_mult: "poly_mult zero_poly p = zero_poly" unfolding zero_poly_def using poly_mult.simps by auto
text ‹equality of polynomials›
definition eq_poly :: "('v :: linorder, 'a :: comm_semiring_1)poly ⇒ ('v,'a)poly ⇒ bool" (infix "=p" 51)
where "p =p q ≡ ∀ α. eval_poly α p = eval_poly α q"
lemma poly_one_mult: "poly_mult one_poly p =p p"
unfolding eq_poly_def one_poly_def by simp
lemma eq_poly_refl[simp]: "p =p p" unfolding eq_poly_def by auto
lemma eq_poly_trans[trans]: "⟦p1 =p p2; p2 =p p3⟧ ⟹ p1 =p p3"
unfolding eq_poly_def by auto
lemma poly_add_comm: "poly_add p q =p poly_add q p" unfolding eq_poly_def by (auto simp: field_simps)
lemma poly_add_assoc: "poly_add p1 (poly_add p2 p3) =p poly_add (poly_add p1 p2) p3" unfolding eq_poly_def by (auto simp: field_simps)
lemma poly_mult_comm: "poly_mult p q =p poly_mult q p" unfolding eq_poly_def by (auto simp: field_simps)
lemma poly_mult_assoc: "poly_mult p1 (poly_mult p2 p3) =p poly_mult (poly_mult p1 p2) p3" unfolding eq_poly_def by (auto simp: field_simps)
lemma poly_distrib: "poly_mult p (poly_add q1 q2) =p poly_add (poly_mult p q1) (poly_mult p q2)" unfolding eq_poly_def by (auto simp: field_simps)
subsection ‹Computing normal forms of polynomials›
fun
poly_of :: "('v :: linorder,'a :: comm_semiring_1)tpoly ⇒ ('v,'a)poly"
where "poly_of (PNum i) = (if i = 0 then [] else [(1,i)])"
| "poly_of (PVar x) = [(var_monom x,1)]"
| "poly_of (PSum []) = zero_poly"
| "poly_of (PSum (p # ps)) = (poly_add (poly_of p) (poly_of (PSum ps)))"
| "poly_of (PMult []) = one_poly"
| "poly_of (PMult (p # ps)) = (poly_mult (poly_of p) (poly_of (PMult ps)))"
text ‹
evaluation is preserved by poly\_of
›
lemma poly_of: "eval_poly α (poly_of p) = eval_tpoly α p"
by (induct p rule: poly_of.induct, (simp add: zero_poly_def one_poly_def)+)
text ‹
poly\_of only generates polynomials that satisfy the invariant
›
lemma poly_of_inv: "poly_inv (poly_of p)"
by (induct p rule: poly_of.induct,
simp add: poly_inv_def monom_inv_def,
simp add: poly_inv_def monom_inv_def,
simp add: zero_poly_inv,
simp add: poly_add_inv,
simp add: one_poly_inv,
simp add: poly_mult_inv)
subsection ‹Powers and substitutions of polynomials›
fun poly_power :: "('v :: linorder, 'a :: comm_semiring_1)poly ⇒ nat ⇒ ('v,'a)poly" where
"poly_power _ 0 = one_poly"
| "poly_power p (Suc n) = poly_mult p (poly_power p n)"
lemma poly_power[simp]: "eval_poly α (poly_power p n) = (eval_poly α p) ^ n"
by (induct n, auto simp: one_poly_def)
lemma poly_power_inv: assumes p: "poly_inv p"
shows "poly_inv (poly_power p n)"
by (induct n, simp add: one_poly_inv, simp add: poly_mult_inv[OF p])
declare poly_power.simps[simp del]
fun monom_list_subst :: "('v ⇒ ('w :: linorder,'a :: comm_semiring_1)poly) ⇒ 'v monom_list ⇒ ('w,'a)poly" where
"monom_list_subst σ [] = one_poly"
| "monom_list_subst σ ((x,p) # m) = poly_mult (poly_power (σ x) p) (monom_list_subst σ m)"
lift_definition monom_list :: "'v :: linorder monom ⇒ 'v monom_list" is "λ x. x" .
definition monom_subst :: "('v :: linorder ⇒ ('w :: linorder,'a :: comm_semiring_1)poly) ⇒ 'v monom ⇒ ('w,'a)poly" where
"monom_subst σ m = monom_list_subst σ (monom_list m)"
lemma monom_list_subst_inv: assumes sub: "⋀ x. poly_inv (σ x)"
shows "poly_inv (monom_list_subst σ m)"
proof (induct m)
case Nil thus ?case by (simp add: one_poly_inv)
next
case (Cons xp m)
obtain x p where xp: "xp = (x,p)" by (cases xp, auto)
show ?case by (simp add: xp, rule poly_mult_inv[OF poly_power_inv[OF sub] Cons])
qed
lemma monom_subst_inv: assumes sub: "⋀ x. poly_inv (σ x)"
shows "poly_inv (monom_subst σ m)"
unfolding monom_subst_def by (rule monom_list_subst_inv[OF sub])
lemma monom_subst[simp]: "eval_poly α (monom_subst σ m) = eval_monom (λ v. eval_poly α (σ v)) m"
unfolding monom_subst_def
proof (transfer fixing: α σ, clarsimp)
fix m
show "monom_inv m ⟹ eval_poly α (monom_list_subst σ m) = eval_monom_list (λv. eval_poly α (σ v)) m"
by (induct m, simp add: one_poly_def, auto simp: field_simps monom_inv_ConsD)
qed
fun poly_subst :: "('v :: linorder ⇒ ('w :: linorder,'a :: comm_semiring_1)poly) ⇒ ('v,'a)poly ⇒ ('w,'a)poly" where
"poly_subst σ [] = zero_poly"
| "poly_subst σ ((m,c) # p) = poly_add (poly_mult [(1,c)] (monom_subst σ m)) (poly_subst σ p)"
lemma poly_subst_inv: assumes sub: "⋀ x. poly_inv (σ x)" and p: "poly_inv p"
shows "poly_inv (poly_subst σ p)"
using p
proof (induct p)
case Nil thus ?case by (simp add: zero_poly_inv)
next
case (Cons mc p)
obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
with Cons(2) have c: "c ≠ 0" and p: "poly_inv p" unfolding poly_inv_def by auto
from c have c: "poly_inv [(1,c)]" unfolding poly_inv_def monom_inv_def by auto
show ?case
by (simp add: mc, rule poly_add_inv[OF poly_mult_inv[OF c monom_subst_inv[OF sub]] Cons(1)[OF p]])
qed
lemma poly_subst: "eval_poly α (poly_subst σ p) = eval_poly (λ v. eval_poly α (σ v)) p"
by (induct p, simp add: zero_poly_def, auto simp: field_simps)
lemma eval_poly_subst:
assumes eq: "⋀ w. f w = eval_poly g (q w)"
shows "eval_poly f p = eval_poly g (poly_subst q p)"
proof (induct p)
case Nil thus ?case by (simp add: zero_poly_def)
next
case (Cons mc p)
obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
have id: "eval_monom f m = eval_monom (λv. eval_poly g (q v)) m"
proof (transfer fixing: f g q, clarsimp)
fix m
show "eval_monom_list f m = eval_monom_list (λv. eval_poly g (q v)) m"
proof (induct m)
case (Cons wp m)
obtain w p where wp: "wp = (w,p)" by (cases wp, auto)
show ?case
by (simp add: wp Cons eq)
qed simp
qed
show ?case
by (simp add: mc Cons id, simp add: field_simps)
qed
lift_definition monom_vars_list :: "'v :: linorder monom ⇒ 'v list" is "map fst" .
lemma monom_vars_list_subst: assumes "⋀ w. w ∈ set (monom_vars_list m) ⟹ f w = g w"
shows "monom_subst f m = monom_subst g m"
unfolding monom_subst_def using assms
proof (transfer fixing: f g)
fix m :: "'a monom_list"
assume eq: "⋀w. w ∈ set (map fst m) ⟹ f w = g w"
thus "monom_list_subst f m = monom_list_subst g m"
proof (induct m)
case (Cons wn m)
hence rec: "monom_list_subst f m = monom_list_subst g m" and eq: "f (fst wn) = g (fst wn)" by auto
show ?case
proof (cases wn)
case (Pair w n)
with eq rec show ?thesis by auto
qed
qed simp
qed
lemma eval_monom_vars_list: assumes "⋀ x. x ∈ set (monom_vars_list xs) ⟹ α x = β x"
shows "eval_monom α xs = eval_monom β xs" using assms
proof (transfer fixing: α β)
fix xs :: "'a monom_list"
assume eq: "⋀w. w ∈ set (map fst xs) ⟹ α w = β w"
thus "eval_monom_list α xs = eval_monom_list β xs"
proof (induct xs)
case (Cons xi xs)
hence IH: "eval_monom_list α xs = eval_monom_list β xs" by auto
obtain x i where xi: "xi = (x,i)" by force
from Cons(2) xi have "α x = β x" by auto
with IH show ?case unfolding xi by auto
qed simp
qed
definition monom_vars where "monom_vars m = set (monom_vars_list m)"
lemma monom_vars_list_1[simp]: "monom_vars_list 1 = []"
by transfer auto
lemma monom_vars_list_var_monom[simp]: "monom_vars_list (var_monom x) = [x]"
by transfer auto
lemma monom_vars_eval_monom:
"(⋀ x. x ∈ monom_vars m ⟹ f x = g x) ⟹ eval_monom f m = eval_monom g m"
by (rule eval_monom_vars_list, auto simp: monom_vars_def)
definition poly_vars_list :: "('v :: linorder,'a)poly ⇒ 'v list" where
"poly_vars_list p = remdups (concat (map (monom_vars_list o fst) p))"
definition poly_vars :: "('v :: linorder,'a)poly ⇒ 'v set" where
"poly_vars p = set (concat (map (monom_vars_list o fst) p))"
lemma poly_vars_list[simp]: "set (poly_vars_list p) = poly_vars p"
unfolding poly_vars_list_def poly_vars_def by auto
lemma poly_vars: assumes eq: "⋀ w. w ∈ poly_vars p ⟹ f w = g w"
shows "poly_subst f p = poly_subst g p"
using eq
proof (induct p)
case (Cons mc p)
hence rec: "poly_subst f p = poly_subst g p" unfolding poly_vars_def by auto
show ?case
proof (cases mc)
case (Pair m c)
with Cons(2) have "⋀ w. w ∈ set (monom_vars_list m) ⟹ f w = g w" unfolding poly_vars_def by auto
hence "monom_subst f m = monom_subst g m"
by (rule monom_vars_list_subst)
with rec Pair show ?thesis by auto
qed
qed simp
lemma poly_var: assumes pv: "v ∉ poly_vars p" and diff: "⋀ w. v ≠ w ⟹ f w = g w"
shows "poly_subst f p = poly_subst g p"
proof (rule poly_vars)
fix w
assume "w ∈ poly_vars p"
thus "f w = g w" using pv diff by (cases "v = w", auto)
qed
lemma eval_poly_vars: assumes "⋀ x. x ∈ poly_vars p ⟹ α x = β x"
shows "eval_poly α p = eval_poly β p"
using assms
proof (induct p)
case Nil thus ?case by simp
next
case (Cons m p)
from Cons(2) have "⋀ x. x ∈ poly_vars p ⟹ α x = β x" unfolding poly_vars_def by auto
from Cons(1)[OF this] have IH: "eval_poly α p = eval_poly β p" .
obtain xs c where m: "m = (xs,c)" by force
from Cons(2) have "⋀ x. x ∈ set (monom_vars_list xs) ⟹ α x = β x" unfolding poly_vars_def m by auto
hence "eval_monom α xs = eval_monom β xs"
by (rule eval_monom_vars_list)
thus ?case unfolding eval_poly.simps IH m by auto
qed
declare poly_subst.simps[simp del]
subsection ‹
Polynomial orders
›
definition pos_assign :: "('v,'a :: ordered_semiring_0)assign ⇒ bool"
where "pos_assign α = (∀ x. α x ≥ 0)"
definition poly_ge :: "('v :: linorder,'a :: poly_carrier)poly ⇒ ('v,'a)poly ⇒ bool" (infix "≥p" 51)
where "p ≥p q = (∀ α. pos_assign α ⟶ eval_poly α p ≥ eval_poly α q)"
lemma poly_ge_refl[simp]: "p ≥p p"
unfolding poly_ge_def using ge_refl by auto
lemma poly_ge_trans[trans]: "⟦p1 ≥p p2; p2 ≥p p3⟧ ⟹ p1 ≥p p3"
unfolding poly_ge_def using ge_trans by blast
lemma pos_assign_monom_list: fixes α :: "('v :: linorder, 'a :: poly_carrier)assign"
assumes pos: "pos_assign α"
shows "eval_monom_list α m ≥ 0"
proof (induct m)
case Nil thus ?case by (simp add: one_ge_zero)
next
case (Cons xp m)
show ?case
proof (cases xp)
case (Pair x p)
from pos[unfolded pos_assign_def] have ge: "α x ≥ 0" by simp
have ge: "α x ^ p ≥ 0"
proof (induct p)
case 0 thus ?case by (simp add: one_ge_zero)
next
case (Suc p)
from ge_trans[OF times_left_mono[OF ge Suc] times_right_mono[OF ge_refl ge]]
show ?case by (simp add: field_simps)
qed
from ge_trans[OF times_right_mono[OF Cons ge] times_left_mono[OF ge_refl Cons]]
show ?thesis
by (simp add: Pair)
qed
qed
lemma pos_assign_monom: fixes α :: "('v :: linorder, 'a :: poly_carrier)assign"
assumes pos: "pos_assign α"
shows "eval_monom α m ≥ 0"
by (transfer fixing: α, rule pos_assign_monom_list[OF pos])
lemma pos_assign_poly: assumes pos: "pos_assign α"
and p: "p ≥p zero_poly"
shows "eval_poly α p ≥ 0"
proof -
from p[unfolded poly_ge_def zero_poly_def] pos
show ?thesis by auto
qed
lemma poly_add_ge_mono: assumes "p1 ≥p p2" shows "poly_add p1 q ≥p poly_add p2 q"
using assms unfolding poly_ge_def by (auto simp: field_simps plus_left_mono)
lemma poly_mult_ge_mono: assumes "p1 ≥p p2" and "q ≥p zero_poly"
shows "poly_mult p1 q ≥p poly_mult p2 q"
using assms unfolding poly_ge_def zero_poly_def by (auto simp: times_left_mono)
context poly_order_carrier
begin
definition poly_gt :: "('v :: linorder,'a)poly ⇒ ('v,'a)poly ⇒ bool" (infix ">p" 51)
where "p >p q = (∀ α. pos_assign α ⟶ eval_poly α p ≻ eval_poly α q)"
lemma poly_gt_imp_poly_ge: "p >p q ⟹ p ≥p q" unfolding poly_ge_def poly_gt_def using gt_imp_ge by blast
abbreviation poly_GT :: "('v :: linorder,'a)poly rel"
where "poly_GT ≡ {(p,q) | p q. p >p q ∧ q ≥p zero_poly}"
lemma poly_compat: "⟦p1 ≥p p2; p2 >p p3⟧ ⟹ p1 >p p3"
unfolding poly_ge_def poly_gt_def using compat by blast
lemma poly_compat2: "⟦p1 >p p2; p2 ≥p p3⟧ ⟹ p1 >p p3"
unfolding poly_ge_def poly_gt_def using compat2 by blast
lemma poly_gt_trans[trans]: "⟦p1 >p p2; p2 >p p3⟧ ⟹ p1 >p p3"
unfolding poly_gt_def using gt_trans by blast
lemma poly_GT_SN: "SN poly_GT"
proof
fix f :: "nat ⇒ ('c :: linorder,'a)poly"
assume f: "∀ i. (f i, f (Suc i)) ∈ poly_GT"
have pos: "pos_assign ((λ x. 0) :: ('v,'a)assign)" (is "pos_assign ?ass") unfolding pos_assign_def using ge_refl by auto
obtain g where g: "⋀ i. g i = eval_poly ?ass (f i)" by auto
from f pos have "∀ i. g (Suc i) ≥ 0 ∧ g i ≻ g (Suc i)" unfolding poly_gt_def g using pos_assign_poly by auto
with SN show False unfolding SN_defs by blast
qed
end
text ‹monotonicity of polynomials›
lemma eval_monom_list_mono: assumes fg: "⋀ x. (f :: ('v :: linorder,'a :: poly_carrier)assign) x ≥ g x"
and g: "⋀ x. g x ≥ 0"
shows "eval_monom_list f m ≥ eval_monom_list g m" "eval_monom_list g m ≥ 0"
proof (atomize(full), induct m)
case Nil show ?case using one_ge_zero by (auto simp: ge_refl)
next
case (Cons xd m)
hence IH1: " eval_monom_list f m ≥ eval_monom_list g m" and IH2: "eval_monom_list g m ≥ 0" by auto
obtain x d where xd: "xd = (x,d)" by force
from pow_mono[OF fg g, of x d] have fgd: "f x ^ d ≥ g x ^ d" and gd: "g x ^ d ≥ 0" by auto
show ?case unfolding xd eval_monom_list.simps
proof (rule conjI, rule ge_trans[OF times_left_mono[OF pow_ge_zero IH1] times_right_mono[OF IH2 fgd]])
show "f x ≥ 0" by (rule ge_trans[OF fg g])
show "eval_monom_list g m * g x ^ d ≥ 0"
by (rule mult_ge_zero[OF IH2 gd])
qed
qed
lemma eval_monom_mono: assumes fg: "⋀ x. (f :: ('v :: linorder,'a :: poly_carrier)assign) x ≥ g x"
and g: "⋀ x. g x ≥ 0"
shows "eval_monom f m ≥ eval_monom g m" "eval_monom g m ≥ 0"
by (atomize(full), transfer fixing: f g, insert eval_monom_list_mono[of g f, OF fg g], auto)
definition poly_weak_mono_all :: "('v :: linorder,'a :: poly_carrier)poly ⇒ bool" where
"poly_weak_mono_all p ≡ ∀ (α :: ('v,'a)assign) β. (∀ x. α x ≥ β x)
⟶ pos_assign β ⟶ eval_poly α p ≥ eval_poly β p"
lemma poly_weak_mono_all_E: assumes p: "poly_weak_mono_all p" and
ge: "⋀ x. f x ≥p g x ∧ g x ≥p zero_poly"
shows "poly_subst f p ≥p poly_subst g p"
unfolding poly_ge_def poly_subst
proof (intro allI impI, rule p[unfolded poly_weak_mono_all_def, rule_format])
fix α :: "('c,'b)assign" and x
show "pos_assign α ⟹ eval_poly α (f x) ≥ eval_poly α (g x)" using ge[of x] unfolding poly_ge_def by auto
next
fix α :: "('c,'b)assign"
assume alpha: "pos_assign α"
show "pos_assign (λv. eval_poly α (g v))"
unfolding pos_assign_def
proof
fix x
show "eval_poly α (g x) ≥ 0"
using ge[of x] unfolding poly_ge_def zero_poly_def using alpha by auto
qed
qed
definition poly_weak_mono :: "('v :: linorder,'a :: poly_carrier)poly ⇒ 'v ⇒ bool" where
"poly_weak_mono p v ≡ ∀ (α :: ('v,'a)assign) β. (∀ x. v ≠ x ⟶ α x = β x) ⟶ pos_assign β ⟶ α v ≥ β v ⟶ eval_poly α p ≥ eval_poly β p"
lemma poly_weak_mono_E: assumes p: "poly_weak_mono p v"
and fgw: "⋀ w. v ≠ w ⟹ f w = g w"
and g: "⋀ w. g w ≥p zero_poly"
and fgv: "f v ≥p g v"
shows "poly_subst f p ≥p poly_subst g p"
unfolding poly_ge_def poly_subst
proof (intro allI impI, rule p[unfolded poly_weak_mono_def, rule_format])
fix α :: "('c,'b)assign"
show "pos_assign α ⟹ eval_poly α (f v) ≥ eval_poly α (g v)" using fgv unfolding poly_ge_def by auto
next
fix α :: "('c,'b)assign"
assume alpha: "pos_assign α"
show "pos_assign (λv. eval_poly α (g v))"
unfolding pos_assign_def
proof
fix x
show "eval_poly α (g x) ≥ 0"
using g[of x] unfolding poly_ge_def zero_poly_def using alpha by auto
qed
next
fix α :: "('c,'b)assign" and x
assume v: "v ≠ x"
show "pos_assign α ⟹ eval_poly α (f x) = eval_poly α (g x)" using fgw[OF v] unfolding poly_ge_def by auto
qed
definition poly_weak_anti_mono :: "('v :: linorder,'a :: poly_carrier)poly ⇒ 'v ⇒ bool" where
"poly_weak_anti_mono p v ≡ ∀ (α :: ('v,'a)assign) β. (∀ x. v ≠ x ⟶ α x = β x) ⟶ pos_assign β ⟶ α v ≥ β v ⟶ eval_poly β p ≥ eval_poly α p"
lemma poly_weak_anti_mono_E: assumes p: "poly_weak_anti_mono p v"
and fgw: "⋀ w. v ≠ w ⟹ f w = g w"
and g: "⋀ w. g w ≥p zero_poly"
and fgv: "f v ≥p g v"
shows "poly_subst g p ≥p poly_subst f p"
unfolding poly_ge_def poly_subst
proof (intro allI impI, rule p[unfolded poly_weak_anti_mono_def, rule_format])
fix α :: "('c,'b)assign"
show "pos_assign α ⟹ eval_poly α (f v) ≥ eval_poly α (g v)" using fgv unfolding poly_ge_def by auto
next
fix α :: "('c,'b)assign"
assume alpha: "pos_assign α"
show "pos_assign (λv. eval_poly α (g v))"
unfolding pos_assign_def
proof
fix x
show "eval_poly α (g x) ≥ 0"
using g[of x] unfolding poly_ge_def zero_poly_def using alpha by auto
qed
next
fix α :: "('c,'b)assign" and x
assume v: "v ≠ x"
show "pos_assign α ⟹ eval_poly α (f x) = eval_poly α (g x)" using fgw[OF v] unfolding poly_ge_def by auto
qed
lemma poly_weak_mono: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
assumes mono: "⋀ v. v ∈ poly_vars p ⟹ poly_weak_mono p v"
shows "poly_weak_mono_all p"
unfolding poly_weak_mono_all_def
proof (intro allI impI)
fix α β :: "('v,'a)assign"
assume all: "∀ x. α x ≥ β x"
assume pos: "pos_assign β"
let ?ab = "λ vs v. if (v ∈ set vs) then α v else β v"
{
fix vs :: "'v list"
assume "set vs ⊆ poly_vars p"
hence "eval_poly (?ab vs) p ≥ eval_poly β p"
proof (induct vs)
case Nil show ?case by (simp add: ge_refl)
next
case (Cons v vs)
hence subset: "set vs ⊆ poly_vars p" and v: "v ∈ poly_vars p" by auto
show ?case
proof (rule ge_trans[OF mono[OF v, unfolded poly_weak_mono_def, rule_format] Cons(1)[OF subset]])
show "pos_assign (?ab vs)" unfolding pos_assign_def
proof
fix x
from pos[unfolded pos_assign_def] have beta: "β x ≥ 0" by simp
from ge_trans[OF all[rule_format] this] have alpha: "α x ≥ 0" .
from alpha beta show "?ab vs x ≥ 0" by auto
qed
show "(?ab (v # vs) v) ≥ (?ab vs v)" using all ge_refl by auto
next
fix x
assume "v ≠ x"
thus "(?ab (v # vs) x) = (?ab vs x)" by simp
qed
qed
}
from this[of "poly_vars_list p", unfolded poly_vars_list]
have "eval_poly (λv. if v ∈ poly_vars p then α v else β v) p ≥ eval_poly β p" by auto
also have "eval_poly (λv. if v ∈ poly_vars p then α v else β v) p = eval_poly α p"
by (rule eval_poly_vars, auto)
finally
show "eval_poly α p ≥ eval_poly β p" .
qed
lemma poly_weak_mono_all: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
assumes p: "poly_weak_mono_all p"
shows "poly_weak_mono p v"
unfolding poly_weak_mono_def
proof (intro allI impI)
fix α β :: "('v,'a)assign"
assume all: "∀x. v ≠ x ⟶ α x = β x"
assume pos: "pos_assign β"
assume v: "α v ≥ β v"
show "eval_poly α p ≥ eval_poly β p"
proof (rule p[unfolded poly_weak_mono_all_def, rule_format, OF _ pos])
fix x
show "α x ≥ β x"
using v all ge_refl[of "β x"] by auto
qed
qed
lemma poly_weak_mono_all_pos:
fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
assumes pos_at_zero: "eval_poly (λ w. 0) p ≥ 0"
and mono: "poly_weak_mono_all p"
shows "p ≥p zero_poly"
unfolding poly_ge_def zero_poly_def
proof (intro allI impI, simp)
fix α :: "('v,'a)assign"
assume pos: "pos_assign α"
show "eval_poly α p ≥ 0"
proof -
let ?id = "λ w. poly_of (PVar w)"
let ?z = "λ w. zero_poly"
have "poly_subst ?id p ≥p poly_subst ?z p"
by (rule poly_weak_mono_all_E[OF mono],
simp, simp add: poly_ge_def zero_poly_def pos_assign_def)
hence "eval_poly α (poly_subst ?id p) ≥ eval_poly α (poly_subst ?z p)" (is "_ ≥ ?res")
unfolding poly_ge_def using pos by simp
also have "?res = eval_poly (λ w. 0) p" by (simp add: poly_subst zero_poly_def)
also have "… ≥ 0" by (rule pos_at_zero)
finally show ?thesis by (simp add: poly_subst)
qed
qed
context poly_order_carrier
begin
definition poly_strict_mono :: "('v :: linorder,'a)poly ⇒ 'v ⇒ bool" where
"poly_strict_mono p v ≡ ∀ (α :: ('v,'a)assign) β. (∀ x. (v ≠ x ⟶ α x = β x)) ⟶ pos_assign β ⟶ α v ≻ β v ⟶ eval_poly α p ≻ eval_poly β p"
lemma poly_strict_mono_E: assumes p: "poly_strict_mono p v"
and fgw: "⋀ w. v ≠ w ⟹ f w = g w"
and g: "⋀ w. g w ≥p zero_poly"
and fgv: "f v >p g v"
shows "poly_subst f p >p poly_subst g p"
unfolding poly_gt_def poly_subst
proof (intro allI impI, rule p[unfolded poly_strict_mono_def, rule_format])
fix α :: "('c,'a)assign"
show "pos_assign α ⟹ eval_poly α (f v) ≻ eval_poly α (g v)" using fgv unfolding poly_gt_def by auto
next
fix α :: "('c,'a)assign"
assume alpha: "pos_assign α"
show "pos_assign (λv. eval_poly α (g v))"
unfolding pos_assign_def
proof
fix x
show "eval_poly α (g x) ≥ 0"
using g[of x] unfolding poly_ge_def zero_poly_def using alpha by auto
qed
next
fix α :: "('c,'a)assign" and x
assume v: "v ≠ x"
show "pos_assign α ⟹ eval_poly α (f x) = eval_poly α (g x)" using fgw[OF v] unfolding poly_ge_def by auto
qed
lemma poly_add_gt_mono: assumes "p1 >p p2" shows "poly_add p1 q >p poly_add p2 q"
using assms unfolding poly_gt_def by (auto simp: field_simps plus_gt_left_mono)
lemma poly_mult_gt_mono:
fixes q :: "('v :: linorder,'a)poly"
assumes gt: "p1 >p p2" and mono: "q ≥p one_poly"
shows "poly_mult p1 q >p poly_mult p2 q"
proof (unfold poly_gt_def, intro impI allI)
fix α :: "('v,'a)assign"
assume p: "pos_assign α"
with gt have gt: "eval_poly α p1 ≻ eval_poly α p2" unfolding poly_gt_def by simp
from mono p have one: "eval_poly α q ≥ 1" unfolding poly_ge_def one_poly_def by auto
show "eval_poly α (poly_mult p1 q) ≻ eval_poly α (poly_mult p2 q)"
using times_gt_mono[OF gt one] by simp
qed
end
subsection ‹Degree of polynomials›
definition monom_list_degree :: "'v monom_list ⇒ nat" where
"monom_list_degree xps ≡ sum_list (map snd xps)"
lift_definition monom_degree :: "'v :: linorder monom ⇒ nat" is monom_list_degree .
definition poly_degree :: "(_,'a) poly ⇒ nat" where
"poly_degree p ≡ max_list (map (λ (m,c). monom_degree m) p)"
definition poly_coeff_sum :: "('v,'a :: ordered_ab_semigroup) poly ⇒ 'a" where
"poly_coeff_sum p ≡ sum_list (map (λ mc. max 0 (snd mc)) p)"
lemma monom_list_degree: "eval_monom_list (λ _. x) m = x ^ monom_list_degree m"
unfolding monom_list_degree_def
proof (induct m)
case Nil show ?case by simp
next
case (Cons mc m)
thus ?case by (cases mc, auto simp: power_add field_simps)
qed
lemma monom_list_var_monom[simp]: "monom_list (var_monom x) = [(x,1)]"
by (transfer, simp)
lemma monom_list_1[simp]: "monom_list 1 = []"
by (transfer, simp)
lemma monom_degree: "eval_monom (λ _. x) m = x ^ monom_degree m"
by (transfer, rule monom_list_degree)
lemma poly_coeff_sum: "poly_coeff_sum p ≥ 0"
unfolding poly_coeff_sum_def
proof (induct p)
case Nil show ?case by (simp add: ge_refl)
next
case (Cons mc p)
have "(∑mc←mc # p. max 0 (snd mc)) = max 0 (snd mc) + (∑mc←p. max 0 (snd mc))" by auto
also have "… ≥ 0 + 0"
by (rule ge_trans[OF plus_left_mono plus_right_mono[OF Cons]], auto)
finally show ?case by simp
qed
lemma poly_degree: assumes x: "x ≥ (1 :: 'a :: poly_carrier)"
shows "poly_coeff_sum p * (x ^ poly_degree p) ≥ eval_poly (λ _. x) p"
proof (induct p)
case Nil show ?case by (simp add: ge_refl poly_degree_def poly_coeff_sum_def)
next
case (Cons mc p)
obtain m c where mc: "mc = (m,c)" by force
from ge_trans[OF x one_ge_zero] have x0: "x ≥ 0" .
have id1: "eval_poly (λ_. x) (mc # p) = x ^ monom_degree m * c + eval_poly (λ_. x) p" unfolding mc by (simp add: monom_degree)
have id2: "poly_coeff_sum (mc # p) * x ^ poly_degree (mc # p) =
x ^ max (monom_degree m) (poly_degree p) * (max 0 c) + poly_coeff_sum p * x ^ max (monom_degree m) (poly_degree p)"
unfolding poly_coeff_sum_def poly_degree_def by (simp add: mc field_simps)
show "poly_coeff_sum (mc # p) * x ^ poly_degree (mc # p) ≥ eval_poly (λ_. x) (mc # p)"
unfolding id1 id2
proof (rule ge_trans[OF plus_left_mono plus_right_mono])
show "x ^ max (monom_degree m) (poly_degree p) * max 0 c ≥ x ^ monom_degree m * c"
by (rule ge_trans[OF times_left_mono[OF _ pow_mono_exp] times_right_mono[OF pow_ge_zero]], insert x x0, auto)
show "poly_coeff_sum p * x ^ max (monom_degree m) (poly_degree p) ≥ eval_poly (λ_. x) p"
by (rule ge_trans[OF times_right_mono[OF poly_coeff_sum pow_mono_exp[OF x]] Cons], auto)
qed
qed
lemma poly_degree_bound: assumes x: "x ≥ (1 :: 'a :: poly_carrier)"
and c: "c ≥ poly_coeff_sum p"
and d: "d ≥ poly_degree p"
shows "c * (x ^ d) ≥ eval_poly (λ _. x) p"
by (rule ge_trans[OF ge_trans[OF
times_left_mono[OF pow_ge_zero[OF ge_trans[OF x one_ge_zero]] c]
times_right_mono[OF poly_coeff_sum pow_mono_exp[OF x d]]] poly_degree[OF x]])
subsection ‹Executable and sufficient criteria to compare polynomials and ensure monotonicity›
text ‹poly\_split extracts the coefficient for a given monomial and returns additionally the remaining polynomial›
definition poly_split :: "('v monom) ⇒ ('v,'a :: zero)poly ⇒ 'a × ('v,'a)poly"
where "poly_split m p ≡ case List.extract (λ (n,_). m = n) p of None ⇒ (0,p) | Some (p1,(_,c),p2) ⇒ (c, p1 @ p2)"
lemma poly_split: assumes "poly_split m p = (c,q)"
shows "p =p (m,c) # q"
proof (cases "List.extract (λ (n,_). m = n) p")
case None
with assms have "(c,q) = (0,p)" unfolding poly_split_def by auto
thus ?thesis unfolding eq_poly_def by auto
next
case (Some res)
obtain p1 mc p2 where "res = (p1,mc,p2)" by (cases res, auto)
with extract_SomeE[OF Some[simplified this]] obtain a where p: "p = p1 @ (m,a) # p2" and res: "res = (p1,(m,a),p2)" by (cases mc, auto)
from Some res assms have c: "c = a" and q: "q = p1 @ p2" unfolding poly_split_def by auto
show ?thesis unfolding eq_poly_def by (simp add: p c q field_simps)
qed
lemma poly_split_eval: assumes "poly_split m p = (c,q)"
shows "eval_poly α p = (eval_monom α m * c) + eval_poly α q"
using poly_split[OF assms] unfolding eq_poly_def by auto
fun check_poly_eq :: "('v,'a :: semiring_0)poly ⇒ ('v,'a)poly ⇒ bool" where
"check_poly_eq [] q = (q = [])"
| "check_poly_eq ((m,c) # p) q = (case List.extract (λ nd. fst nd = m) q of
None ⇒ False
| Some (q1,(_,d),q2) ⇒ c = d ∧ check_poly_eq p (q1 @ q2))"
lemma check_poly_eq: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
assumes chk: "check_poly_eq p q"
shows "p =p q" unfolding eq_poly_def
proof
fix α
from chk show "eval_poly α p = eval_poly α q"
proof (induct p arbitrary: q)
case Nil
thus ?case by auto
next
case (Cons mc p)
obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
show ?case
proof (cases "List.extract (λ mc. fst mc = m) q")
case None
with Cons(2) show ?thesis unfolding mc by simp
next
case (Some res)
obtain q1 md q2 where "res = (q1,md,q2)" by (cases res, auto)
with extract_SomeE[OF Some[simplified this]] obtain d where q: "q = q1 @ (m,d) # q2" and res: "res = (q1,(m,d),q2)"
by (cases md, auto)
from Cons(2) Some mc res have rec: "check_poly_eq p (q1 @ q2)" and c: "c = d" by auto
from Cons(1)[OF rec] have p: "eval_poly α p = eval_poly α (q1 @ q2)" .
show ?thesis unfolding mc eval_poly.simps c p q by (simp add: ac_simps)
qed
qed
qed
declare check_poly_eq.simps[simp del]
fun check_poly_ge :: "('v,'a :: ordered_semiring_0)poly ⇒ ('v,'a)poly ⇒ bool" where
"check_poly_ge [] q = list_all (λ (_,d). 0 ≥ d) q"
| "check_poly_ge ((m,c) # p) q = (case List.extract (λ nd. fst nd = m) q of
None ⇒ c ≥ 0 ∧ check_poly_ge p q
| Some (q1,(_,d),q2) ⇒ c ≥ d ∧ check_poly_ge p (q1 @ q2))"
lemma check_poly_ge: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
shows "check_poly_ge p q ⟹ p ≥p q"
proof (induct p arbitrary: q)
case Nil
hence "∀ (n,d) ∈ set q. 0 ≥ d" using list_all_iff[of _ q] by auto
hence "[] ≥p q"
proof (induct q)
case Nil thus ?case by (simp)
next
case (Cons nd q)
hence rec: "[] ≥p q" by simp
show ?case
proof (cases nd)
case (Pair n d)
with Cons have ge: "0 ≥ d" by auto
show ?thesis
proof (simp only: Pair, unfold poly_ge_def, intro allI impI)
fix α :: "('v,'a)assign"
assume pos: "pos_assign α"
have ge: "0 ≥ eval_monom α n * d"
using times_right_mono[OF pos_assign_monom[OF pos, of n] ge] by simp
from rec[unfolded poly_ge_def] pos have ge2: "0 ≥ eval_poly α q" by auto
show "eval_poly α [] ≥ eval_poly α ((n,d) # q)" using ge_trans[OF plus_left_mono[OF ge] plus_right_mono[OF ge2]]
by simp
qed
qed
qed
thus ?case by simp
next
case (Cons mc p)
obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
show ?case
proof (cases "List.extract (λ mc. fst mc = m) q")
case None
with Cons(2) have rec: "check_poly_ge p q" and c: "c ≥ 0" using mc by auto
from Cons(1)[OF rec] have rec: "p ≥p q" .
show ?thesis
proof (simp only: mc, unfold poly_ge_def, intro allI impI)
fix α :: "('v,'a)assign"
assume pos: "pos_assign α"
have ge: "eval_monom α m * c ≥ 0"
using times_right_mono[OF pos_assign_monom[OF pos, of m] c] by simp
from rec have pq: "eval_poly α p ≥ eval_poly α q" unfolding poly_ge_def using pos by auto
show "eval_poly α ((m,c) # p) ≥ eval_poly α q"
using ge_trans[OF plus_left_mono[OF ge] plus_right_mono[OF pq]] by simp
qed
next
case (Some res)
obtain q1 md q2 where "res = (q1,md,q2)" by (cases res, auto)
with extract_SomeE[OF Some[simplified this]] obtain d where q: "q = q1 @ (m,d) # q2" and res: "res = (q1,(m,d),q2)"
by (cases md, auto)
from Cons(2) Some mc res have rec: "check_poly_ge p (q1 @ q2)" and c: "c ≥ d" by auto
from Cons(1)[OF rec] have p: "p ≥p q1 @ q2" .
show ?thesis
proof (simp only: mc, unfold poly_ge_def, intro allI impI)
fix α :: "('v,'a)assign"
assume pos: "pos_assign α"
have ge: "eval_monom α m * c ≥ eval_monom α m * d"
using times_right_mono[OF pos_assign_monom[OF pos, of m] c]
by simp
from p have ge2: "eval_poly α p ≥ eval_poly α (q1 @ q2)" unfolding poly_ge_def using pos by auto
show "eval_poly α ((m,c) # p) ≥ eval_poly α q" using ge_trans[OF plus_left_mono[OF ge] plus_right_mono[OF ge2]]
by (simp add: q field_simps)
qed
qed
qed
declare check_poly_ge.simps[simp del]
definition check_poly_weak_mono_all :: "('v,'a :: ordered_semiring_0)poly ⇒ bool"
where "check_poly_weak_mono_all p ≡ list_all (λ (m,c). c ≥ 0) p"
lemma check_poly_weak_mono_all: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
assumes "check_poly_weak_mono_all p" shows "poly_weak_mono_all p"
unfolding poly_weak_mono_all_def
proof (intro allI impI)
fix f g :: "('v,'a)assign"
assume fg: "∀ x. f x ≥ g x"
and pos: "pos_assign g"
hence fg: "⋀ x. f x ≥ g x" by auto
from pos[unfolded pos_assign_def] have g: "⋀ x. g x ≥ 0" ..
from assms have "⋀ m c. (m,c) ∈ set p ⟹ c ≥ 0" unfolding check_poly_weak_mono_all_def by (auto simp: list_all_iff)
thus "eval_poly f p ≥ eval_poly g p"
proof (induct p)
case Nil thus ?case by (simp add: ge_refl)
next
case (Cons mc p)
hence IH: "eval_poly f p ≥ eval_poly g p" by auto
show ?case
proof (cases mc)
case (Pair m c)
with Cons have c: "c ≥ 0" by auto
show ?thesis unfolding Pair eval_poly.simps fst_conv snd_conv
proof (rule ge_trans[OF plus_left_mono[OF times_left_mono[OF c]] plus_right_mono[OF IH]])
show "eval_monom f m ≥ eval_monom g m"
by (rule eval_monom_mono(1)[OF fg g])
qed
qed
qed
qed
lemma check_poly_weak_mono_all_pos:
assumes "check_poly_weak_mono_all p" shows "p ≥p zero_poly"
unfolding zero_poly_def
proof (rule check_poly_ge)
from assms have "⋀ m c. (m,c) ∈ set p ⟹ c ≥ 0" unfolding check_poly_weak_mono_all_def by (auto simp: list_all_iff)
thus "check_poly_ge p []"
by (induct p, simp add: check_poly_ge.simps, clarify, auto simp: check_poly_ge.simps extract_Nil_code)
qed
text ‹better check for weak monotonicity for discrete carriers:
$p$ is monotone in $v$ if $p(\ldots v+1 \ldots) \geq p(\ldots v \ldots)$›
definition check_poly_weak_mono_discrete :: "('v :: linorder,'a :: poly_carrier)poly ⇒ 'v ⇒ bool"
where "check_poly_weak_mono_discrete p v ≡ check_poly_ge (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p) p"
definition check_poly_weak_mono_and_pos :: "bool ⇒ ('v :: linorder,'a :: poly_carrier)poly ⇒ bool"
where "check_poly_weak_mono_and_pos discrete p ≡
if discrete then list_all (λ v. check_poly_weak_mono_discrete p v) (poly_vars_list p) ∧ eval_poly (λ w. 0) p ≥ 0
else check_poly_weak_mono_all p"
definition check_poly_weak_anti_mono_discrete :: "('v :: linorder,'a :: poly_carrier)poly ⇒ 'v ⇒ bool"
where "check_poly_weak_anti_mono_discrete p v ≡ check_poly_ge p (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p)"
context poly_order_carrier
begin
lemma check_poly_weak_mono_discrete:
fixes v :: "'v :: linorder" and p :: "('v,'a)poly"
assumes discrete and check: "check_poly_weak_mono_discrete p v"
shows "poly_weak_mono p v"
unfolding poly_weak_mono_def
proof (intro allI impI)
fix f g :: "('v,'a)assign"
assume fgw: "∀ w. (v ≠ w ⟶ f w = g w)"
and gass: "pos_assign g"
and v: "f v ≥ g v"
from fgw have w: "⋀ w. v ≠ w ⟹ f w = g w" by auto
from assms check_poly_ge have ge: "poly_ge (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p) p" (is "poly_ge ?p1 p") unfolding check_poly_weak_mono_discrete_def by blast
from discrete[OF ‹discrete› v] obtain k' where id: "f v = (((+) 1)^^k') (g v)" by auto
show "eval_poly f p ≥ eval_poly g p"
proof (cases k')
case 0
{
fix x
have "f x = g x" using id 0 w by (cases "x = v", auto)
}
hence "f = g" ..
thus ?thesis using ge_refl by simp
next
case (Suc k)
with id have "f v = (((+) 1)^^(Suc k)) (g v)" by simp
with w gass show "eval_poly f p ≥ eval_poly g p"
proof (induct k arbitrary: f g rule: less_induct)
case (less k)
show ?case
proof (cases k)
case 0
with less have id0: "f v = 1 + g v" by simp
have id1: "eval_poly f p = eval_poly g ?p1"
proof (rule eval_poly_subst)
fix w
show "f w = eval_poly g (poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w))"
proof (cases "w = v")
case True
show ?thesis by (simp add: True id0 zero_poly_def)
next
case False
with less have "f w = g w" by simp
thus ?thesis by (simp add: False)
qed
qed
have "eval_poly g ?p1 ≥ eval_poly g p" using ge less unfolding poly_ge_def by simp
with id1 show ?thesis by simp
next
case (Suc kk)
obtain g' where g': "g' = (λ w. if (w = v) then 1 + g w else g w)" by auto
have "(1 :: 'a) + g v ≥ 1 + 0"
by (rule plus_right_mono, simp add: less(3)[unfolded pos_assign_def])
also have "1 + (0 :: 'a) = 1" by simp
also have "… ≥ 0" by (rule one_ge_zero)
finally have g'pos: "pos_assign g'" using less(3) unfolding pos_assign_def
by (simp add: g')
{
fix w
assume "v ≠ w"
hence "f w = g' w"
unfolding g' by (simp add: less)
} note w = this
have eq: "f v = ((+) (1 :: 'a) ^^ Suc kk) ((g' v))"
by (simp add: less(4) g' Suc, rule arg_cong[where f = "(+) 1"], induct kk, auto)
from Suc have kk: "kk < k" by simp
from less(1)[OF kk w g'pos] eq
have rec1: "eval_poly f p ≥ eval_poly g' p" by simp
{
fix w
assume "v ≠ w"
hence "g' w = g w"
unfolding g' by simp
} note w = this
from Suc have z: "0 < k" by simp
from less(1)[OF z w less(3)] g'
have rec2: "eval_poly g' p ≥ eval_poly g p" by simp
show ?thesis by (rule ge_trans[OF rec1 rec2])
qed
qed
qed
qed
lemma check_poly_weak_anti_mono_discrete:
fixes v :: "'v :: linorder" and p :: "('v,'a)poly"
assumes discrete and check: "check_poly_weak_anti_mono_discrete p v"
shows "poly_weak_anti_mono p v"
unfolding poly_weak_anti_mono_def
proof (intro allI impI)
fix f g :: "('v,'a)assign"
assume fgw: "∀ w. (v ≠ w ⟶ f w = g w)"
and gass: "pos_assign g"
and v: "f v ≥ g v"
from fgw have w: "⋀ w. v ≠ w ⟹ f w = g w" by auto
from assms check_poly_ge have ge: "poly_ge p (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p)" (is "poly_ge p ?p1") unfolding check_poly_weak_anti_mono_discrete_def by blast
from discrete[OF ‹discrete› v] obtain k' where id: "f v = (((+) 1)^^k') (g v)" by auto
show "eval_poly g p ≥ eval_poly f p"
proof (cases k')
case 0
{
fix x
have "f x = g x" using id 0 w by (cases "x = v", auto)
}
hence "f = g" ..
thus ?thesis using ge_refl by simp
next
case (Suc k)
with id have "f v = (((+) 1)^^(Suc k)) (g v)" by simp
with w gass show "eval_poly g p ≥ eval_poly f p"
proof (induct k arbitrary: f g rule: less_induct)
case (less k)
show ?case
proof (cases k)
case 0
with less have id0: "f v = 1 + g v" by simp
have id1: "eval_poly f p = eval_poly g ?p1"
proof (rule eval_poly_subst)
fix w
show "f w = eval_poly g (poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w))"
proof (cases "w = v")
case True
show ?thesis by (simp add: True id0 zero_poly_def)
next
case False
with less have "f w = g w" by simp
thus ?thesis by (simp add: False)
qed
qed
have "eval_poly g p ≥ eval_poly g ?p1" using ge less unfolding poly_ge_def by simp
with id1 show ?thesis by simp
next
case (Suc kk)
obtain g' where g': "g' = (λ w. if (w = v) then 1 + g w else g w)" by auto
have "(1 :: 'a) + g v ≥ 1 + 0"
by (rule plus_right_mono, simp add: less(3)[unfolded pos_assign_def])
also have "(1 :: 'a) + 0 = 1" by simp
also have "… ≥ 0" by (rule one_ge_zero)
finally have g'pos: "pos_assign g'" using less(3) unfolding pos_assign_def
by (simp add: g')
{
fix w
assume "v ≠ w"
hence "f w = g' w"
unfolding g' by (simp add: less)
} note w = this
have eq: "f v = ((+) (1 :: 'a) ^^ Suc kk) ((g' v))"
by (simp add: less(4) g' Suc, rule arg_cong[where f = "(+) 1"], induct kk, auto)
from Suc have kk: "kk < k" by simp
from less(1)[OF kk w g'pos] eq
have rec1: "eval_poly g' p ≥ eval_poly f p" by simp
{
fix w
assume "v ≠ w"
hence "g' w = g w"
unfolding g' by simp
} note w = this
from Suc have z: "0 < k" by simp
from less(1)[OF z w less(3)] g'
have rec2: "eval_poly g p ≥ eval_poly g' p" by simp
show ?thesis by (rule ge_trans[OF rec2 rec1])
qed
qed
qed
qed
lemma check_poly_weak_mono_and_pos:
fixes p :: "('v :: linorder,'a)poly"
assumes "check_poly_weak_mono_and_pos discrete p"
shows "poly_weak_mono_all p ∧ (p ≥p zero_poly)"
proof (cases discrete)
case False
with assms have c: "check_poly_weak_mono_all p" unfolding check_poly_weak_mono_and_pos_def
by auto
from check_poly_weak_mono_all[OF c] check_poly_weak_mono_all_pos[OF c] show ?thesis by auto
next
case True
with assms have c: "list_all (λ v. check_poly_weak_mono_discrete p v) (poly_vars_list p)" and g: "eval_poly (λ w. 0) p ≥ 0"
unfolding check_poly_weak_mono_and_pos_def by auto
have m: "poly_weak_mono_all p"
proof (rule poly_weak_mono)
fix v :: 'v
assume v: "v ∈ poly_vars p"
show "poly_weak_mono p v"
by (rule check_poly_weak_mono_discrete[OF True], insert c[unfolded list_all_iff] v, auto)
qed
have m': "poly_weak_mono_all p"
proof (rule poly_weak_mono)
fix v :: 'v
assume v: "v ∈ poly_vars p"
show "poly_weak_mono p v"
by (rule check_poly_weak_mono_discrete[OF True], insert c[unfolded list_all_iff] v, auto)
qed
from poly_weak_mono_all_pos[OF g m'] m show ?thesis by auto
qed
end
definition check_poly_weak_mono :: "('v :: linorder,'a :: ordered_semiring_0)poly ⇒ 'v ⇒ bool"
where "check_poly_weak_mono p v ≡ list_all (λ (m,c). c ≥ 0 ∨ v ∉ monom_vars m) p"
lemma check_poly_weak_mono: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
assumes "check_poly_weak_mono p v" shows "poly_weak_mono p v"
unfolding poly_weak_mono_def
proof (intro allI impI)
fix f g :: "('v,'a)assign"
assume "∀ x. v ≠ x ⟶ f x = g x"
and pos: "pos_assign g"
and ge: "f v ≥ g v"
hence fg: "⋀ x. v ≠ x ⟹ f x = g x" by auto
from pos[unfolded pos_assign_def] have g: "⋀ x. g x ≥ 0" ..
from assms have "⋀ m c. (m,c) ∈ set p ⟹ c ≥ 0 ∨ v ∉ monom_vars m" unfolding check_poly_weak_mono_def by (auto simp: list_all_iff)
thus "eval_poly f p ≥ eval_poly g p"
proof (induct p)
case (Cons mc p)
hence IH: "eval_poly f p ≥ eval_poly g p" by auto
obtain m c where mc: "mc = (m,c)" by force
with Cons have c: "c ≥ 0 ∨ v ∉ monom_vars m" by auto
show ?case unfolding mc eval_poly.simps fst_conv snd_conv
proof (rule ge_trans[OF plus_left_mono plus_right_mono[OF IH]])
from c show "eval_monom f m * c ≥ eval_monom g m * c"
proof
assume c: "c ≥ 0"
show ?thesis
proof (rule times_left_mono[OF c], rule eval_monom_mono(1)[OF _ g])
fix x
show "f x ≥ g x" using ge fg[of x] by (cases "x = v", auto simp: ge_refl)
qed
next
assume v: "v ∉ monom_vars m"
have "eval_monom f m = eval_monom g m"
by (rule monom_vars_eval_monom, insert fg v, fast)
thus ?thesis by (simp add: ge_refl)
qed
qed
qed (simp add: ge_refl)
qed
definition check_poly_weak_mono_smart :: "bool ⇒ ('v :: linorder,'a :: poly_carrier)poly ⇒ 'v ⇒ bool"
where "check_poly_weak_mono_smart discrete ≡ if discrete then check_poly_weak_mono_discrete else check_poly_weak_mono"
lemma (in poly_order_carrier) check_poly_weak_mono_smart: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
shows "check_poly_weak_mono_smart discrete p v ⟹ poly_weak_mono p v"
unfolding check_poly_weak_mono_smart_def
using check_poly_weak_mono check_poly_weak_mono_discrete by (cases discrete, auto)
definition check_poly_weak_anti_mono :: "('v :: linorder,'a :: ordered_semiring_0)poly ⇒ 'v ⇒ bool"
where "check_poly_weak_anti_mono p v ≡ list_all (λ (m,c). 0 ≥ c ∨ v ∉ monom_vars m) p"
lemma check_poly_weak_anti_mono: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
assumes "check_poly_weak_anti_mono p v" shows "poly_weak_anti_mono p v"
unfolding poly_weak_anti_mono_def
proof (intro allI impI)
fix f g :: "('v,'a)assign"
assume "∀ x. v ≠ x ⟶ f x = g x"
and pos: "pos_assign g"
and ge: "f v ≥ g v"
hence fg: "⋀ x. v ≠ x ⟹ f x = g x" by auto
from pos[unfolded pos_assign_def] have g: "⋀ x. g x ≥ 0" ..
from assms have "⋀ m c. (m,c) ∈ set p ⟹ 0 ≥ c ∨ v ∉ monom_vars m" unfolding check_poly_weak_anti_mono_def by (auto simp: list_all_iff)
thus "eval_poly g p ≥ eval_poly f p"
proof (induct p)
case Nil thus ?case by (simp add: ge_refl)
next
case (Cons mc p)
hence IH: "eval_poly g p ≥ eval_poly f p" by auto
obtain m c where mc: "mc = (m,c)" by force
with Cons have c: "0 ≥ c ∨ v ∉ monom_vars m" by auto
show ?case unfolding mc eval_poly.simps fst_conv snd_conv
proof (rule ge_trans[OF plus_left_mono plus_right_mono[OF IH]])
from c show "eval_monom g m * c ≥ eval_monom f m * c"
proof
assume c: "0 ≥ c"
show ?thesis
proof (rule times_left_anti_mono[OF eval_monom_mono(1)[OF _ g] c])
fix x
show "f x ≥ g x" using ge fg[of x] by (cases "x = v", auto simp: ge_refl)
qed
next
assume v: "v ∉ monom_vars m"
have "eval_monom f m = eval_monom g m"
by (rule monom_vars_eval_monom, insert fg v, fast)
thus ?thesis by (simp add: ge_refl)
qed
qed
qed
qed
definition check_poly_weak_anti_mono_smart :: "bool ⇒ ('v :: linorder,'a :: poly_carrier)poly ⇒ 'v ⇒ bool"
where "check_poly_weak_anti_mono_smart discrete ≡ if discrete then check_poly_weak_anti_mono_discrete else check_poly_weak_anti_mono"
lemma (in poly_order_carrier) check_poly_weak_anti_mono_smart: fixes p :: "('v :: linorder,'a :: poly_carrier)poly"
shows "check_poly_weak_anti_mono_smart discrete p v ⟹ poly_weak_anti_mono p v"
unfolding check_poly_weak_anti_mono_smart_def
using check_poly_weak_anti_mono[of p v] check_poly_weak_anti_mono_discrete[of p v]
by (cases discrete, auto)
definition check_poly_gt :: "('a ⇒ 'a ⇒ bool) ⇒ ('v :: linorder,'a :: ordered_semiring_0)poly ⇒ ('v,'a)poly ⇒ bool"
where "check_poly_gt gt p q ≡ let (a1,p1) = poly_split 1 p; (b1,q1) = poly_split 1 q in gt a1 b1 ∧ check_poly_ge p1 q1"
fun univariate_power_list :: "'v ⇒ 'v monom_list ⇒ nat option" where
"univariate_power_list x [(y,n)] = (if x = y then Some n else None)"
| "univariate_power_list _ _ = None"
lemma univariate_power_list: assumes "monom_inv m" "univariate_power_list x m = Some n"
shows "sum_var_list m = (λ y. if x = y then n else 0)"
"eval_monom_list α m = ((α x)^n)"
"n ≥ 1"
proof -
have m: "m = [(x,n)]" using assms
by (induct x m rule: univariate_power_list.induct, auto split: if_splits)
show "eval_monom_list α m = ((α x)^n)" "sum_var_list m = (λ y. if x = y then n else 0)"
"n ≥ 1" using assms(1)
unfolding m monom_inv_def by (auto simp: sum_var_list_def)
qed
lift_definition univariate_power :: "'v :: linorder ⇒ 'v monom ⇒ nat option"
is univariate_power_list .
lemma univariate_power: assumes "univariate_power x m = Some n"
shows "sum_var m = (λ y. if x = y then n else 0)"
"eval_monom α m = ((α x)^n)"
"n ≥ 1"
by (atomize(full), insert assms, transfer, auto dest: univariate_power_list)
lemma univariate_power_var_monom: "univariate_power y (var_monom x) = (if x = y then Some 1 else None)"
by (transfer, auto)
definition check_monom_strict_mono :: "bool ⇒ 'v :: linorder monom ⇒ 'v ⇒ bool" where
"check_monom_strict_mono pm m v ≡ case univariate_power v m of
Some p ⇒ pm ∨ p = 1
| None ⇒ False"
definition check_poly_strict_mono :: "bool ⇒ ('v :: linorder, 'a :: poly_carrier)poly ⇒ 'v ⇒ bool"
where "check_poly_strict_mono pm p v ≡ list_ex (λ (m,c). (c ≥ 1) ∧ check_monom_strict_mono pm m v) p"
definition check_poly_strict_mono_discrete :: "('a :: poly_carrier ⇒ 'a ⇒ bool) ⇒ ('v :: linorder,'a)poly ⇒ 'v ⇒ bool"
where "check_poly_strict_mono_discrete gt p v ≡ check_poly_gt gt (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p) p "
definition check_poly_strict_mono_smart :: "bool ⇒ bool ⇒ ('a :: poly_carrier ⇒ 'a ⇒ bool) ⇒ ('v :: linorder,'a)poly ⇒ 'v ⇒ bool"
where "check_poly_strict_mono_smart discrete pm gt p v ≡
if discrete then check_poly_strict_mono_discrete gt p v else check_poly_strict_mono pm p v"
context poly_order_carrier
begin
lemma check_monom_strict_mono: fixes α β :: "('v :: linorder,'a)assign" and v :: 'v and m :: "'v monom"
assumes check: "check_monom_strict_mono power_mono m v"
and gt: "α v ≻ β v"
and ge: "β v ≥ 0"
shows "eval_monom α m ≻ eval_monom β m"
proof -
from check[unfolded check_monom_strict_mono_def] obtain n where
uni: "univariate_power v m = Some n" and 1: "¬ power_mono ⟹ n = 1"
by (auto split: option.splits)
from univariate_power[OF uni]
have n1: "n ≥ 1" and eval: "eval_monom a m = a v ^ n" for a :: "('v,'a)assign"
by auto
show ?thesis
proof (cases power_mono)
case False
with gt 1[OF this] show ?thesis unfolding eval by auto
next
case True
from power_mono[OF True gt ge n1] show ?thesis unfolding eval .
qed
qed
lemma check_poly_strict_mono:
assumes check1: "check_poly_strict_mono power_mono p v"
and check2: "check_poly_weak_mono_all p"
shows "poly_strict_mono p v"
unfolding poly_strict_mono_def
proof (intro allI impI)
fix f g :: "('b,'a)assign"
assume fgw: "∀ w. (v ≠ w ⟶ f w = g w)"
and pos: "pos_assign g"
and fgv: "f v ≻ g v"
from pos[unfolded pos_assign_def] have g: "⋀ x. g x ≥ 0" ..
{
fix w
have "f w ≥ g w"
proof (cases "v = w")
case False
with fgw ge_refl show ?thesis by auto
next
case True
from fgv[unfolded True] show ?thesis by (rule gt_imp_ge)
qed
} note fgw2 = this
let ?e = "eval_poly"
show "?e f p ≻ ?e g p"
using check1[unfolded check_poly_strict_mono_def, simplified list_ex_iff]
check2[unfolded check_poly_weak_mono_all_def, simplified list_all_iff, THEN bspec]
proof (induct p)
case Nil thus ?case by simp
next
case (Cons mc p)
obtain m c where mc: "mc = (m,c)" by (cases mc, auto)
show ?case
proof (cases "c ≥ 1 ∧ check_monom_strict_mono power_mono m v")
case True
hence c: "c ≥ 1" and m: "check_monom_strict_mono power_mono m v" by blast+
from times_gt_mono[OF check_monom_strict_mono[OF m, of f g, OF fgv g] c]
have gt: "eval_monom f m * c ≻ eval_monom g m * c" .
from Cons(3) have "check_poly_weak_mono_all p" unfolding check_poly_weak_mono_all_def list_all_iff by auto
from check_poly_weak_mono_all[OF this, unfolded poly_weak_mono_all_def, rule_format, OF fgw2 pos]
have ge: "?e f p ≥ ?e g p" .
from compat2[OF plus_gt_left_mono[OF gt] plus_right_mono[OF ge]]
show ?thesis unfolding mc by simp
next
case False
with Cons(2) mc have "∃ mc ∈ set p. (λ (m,c). c ≥ 1 ∧ check_monom_strict_mono power_mono m v) mc" by auto
from Cons(1)[OF this] Cons(3) have rec: "?e f p ≻ ?e g p" by simp
from Cons(3) mc have c: "c ≥ 0" by auto
from times_left_mono[OF c eval_monom_mono(1)[OF fgw2 g]]
have ge: "eval_monom f m * c ≥ eval_monom g m * c" .
from compat2[OF plus_gt_left_mono[OF rec] plus_right_mono[OF ge]]
show ?thesis by (simp add: mc field_simps)
qed
qed
qed
lemma check_poly_gt:
fixes p :: "('v :: linorder,'a)poly"
assumes "check_poly_gt gt p q" shows "p >p q"
proof -
obtain a1 p1 where p: "poly_split 1 p = (a1,p1)" by force
obtain b1 q1 where q: "poly_split 1 q = (b1,q1)" by force
from p q assms have gt: "a1 ≻ b1" and ge: "p1 ≥p q1" unfolding check_poly_gt_def using check_poly_ge[of p1 q1] by auto
show ?thesis
proof (unfold poly_gt_def, intro impI allI)
fix α :: "('v,'a)assign"
assume "pos_assign α"
with ge have ge: "eval_poly α p1 ≥ eval_poly α q1" unfolding poly_ge_def by simp
from plus_gt_left_mono[OF gt] compat[OF plus_left_mono[OF ge]] have gt: "a1 + eval_poly α p1 ≻ b1 + eval_poly α q1" by (force simp: field_simps)
show "eval_poly α p ≻ eval_poly α q"
by (simp add: poly_split[OF p, unfolded eq_poly_def] poly_split[OF q, unfolded eq_poly_def] gt)
qed
qed
lemma check_poly_strict_mono_discrete:
fixes v :: "'v :: linorder" and p :: "('v,'a)poly"
assumes discrete and check: "check_poly_strict_mono_discrete gt p v"
shows "poly_strict_mono p v"
unfolding poly_strict_mono_def
proof (intro allI impI)
fix f g :: "('v,'a)assign"
assume fgw: "∀ w. (v ≠ w ⟶ f w = g w)"
and gass: "pos_assign g"
and v: "f v ≻ g v"
from gass have g: "⋀ x. g x ≥ 0" unfolding pos_assign_def ..
from fgw have w: "⋀ w. v ≠ w ⟹ f w = g w" by auto
from assms check_poly_gt have gt: "poly_gt (poly_subst (λ w. poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w)) p) p" (is "poly_gt ?p1 p") unfolding check_poly_strict_mono_discrete_def by blast
from discrete[OF ‹discrete› gt_imp_ge[OF v]] obtain k' where id: "f v = (((+) 1)^^k') (g v)" by auto
{
assume "k' = 0"
from v[unfolded id this] have "g v ≻ g v" by simp
hence False using SN g[of v] unfolding SN_defs by auto
}
with id obtain k where id: "f v = (((+) 1)^^(Suc k)) (g v)" by (cases k', auto)
with w gass
show "eval_poly f p ≻ eval_poly g p"
proof (induct k arbitrary: f g rule: less_induct)
case (less k)
show ?case
proof (cases k)
case 0
with less(4) have id0: "f v = 1 + g v" by simp
have id1: "eval_poly f p = eval_poly g ?p1"
proof (rule eval_poly_subst)
fix w
show "f w = eval_poly g (poly_of (if w = v then PSum [PNum 1, PVar v] else PVar w))"
proof (cases "w = v")
case True
show ?thesis by (simp add: True id0 zero_poly_def)
next
case False
with less have "f w = g w" by simp
thus ?thesis by (simp add: False)
qed
qed
have "eval_poly g ?p1 ≻ eval_poly g p" using gt less unfolding poly_gt_def by simp
with id1 show ?thesis by simp
next
case (Suc kk)
obtain g' where g': "g' = (λ w. if (w = v) then 1 + g w else g w)" by auto
have "(1 :: 'a) + g v ≥ 1 + 0"
by (rule plus_right_mono, simp add: less(3)[unfolded pos_assign_def])
also have "(1 :: 'a) + 0 = 1" by simp
also have "… ≥ 0" by (rule one_ge_zero)
finally have g'pos: "pos_assign g'" using less(3) unfolding pos_assign_def
by (simp add: g')
{
fix w
assume "v ≠ w"
hence "f w = g' w"
unfolding g' by (simp add: less)
} note w = this
have eq: "f v = ((+) (1 :: 'a) ^^ Suc kk) ((g' v))"
by (simp add: less(4) g' Suc, rule arg_cong[where f = "(+) 1"], induct kk, auto)
from Suc have kk: "kk < k" by simp
from less(1)[OF kk w g'pos] eq
have rec1: "eval_poly f p ≻ eval_poly g' p" by simp
{
fix w
assume "v ≠ w"
hence "g' w = g w"
unfolding g' by simp
} note w = this
from Suc have z: "0 < k" by simp
from less(1)[OF z w less(3)] g'
have rec2: "eval_poly g' p ≻ eval_poly g p" by simp
show ?thesis by (rule gt_trans[OF rec1 rec2])
qed
qed
qed
lemma check_poly_strict_mono_smart:
assumes check1: "check_poly_strict_mono_smart discrete power_mono gt p v"
and check2: "check_poly_weak_mono_and_pos discrete p"
shows "poly_strict_mono p v"
proof (cases discrete)
case True
with check1[unfolded check_poly_strict_mono_smart_def]
check_poly_strict_mono_discrete[OF True]
show ?thesis by auto
next
case False
from check_poly_strict_mono[OF check1[unfolded check_poly_strict_mono_smart_def, simplified False, simplified]]
check2[unfolded check_poly_weak_mono_and_pos_def, simplified False, simplified]
show ?thesis by auto
qed
end
end
Theory Show_Polynomials
section ‹Displaying Polynomials›
theory Show_Polynomials
imports
Polynomials
Show.Show_Instances
begin
fun shows_monom_list :: "('v :: {linorder,show})monom_list ⇒ string ⇒ string" where
"shows_monom_list [(x,p)] = (if p = 1 then shows x else shows x +@+ shows_string ''^'' +@+ shows p)"
| "shows_monom_list ((x,p) # m) = ((if p = 1 then shows x else shows x +@+ shows_string ''^'' +@+ shows p) +@+ shows_string ''*'' +@+ shows_monom_list m)"
| "shows_monom_list [] = shows_string ''1''"
instantiation monom :: ("{linorder,show}") "show"
begin
lift_definition shows_prec_monom :: "nat ⇒ 'a monom ⇒ shows" is "λ n. shows_monom_list" .
lemma shows_prec_monom_append [show_law_simps]:
"shows_prec d (m :: 'a monom) (r @ s) = shows_prec d m r @ s"
proof (transfer fixing: d r s)
fix m :: "'a monom_list"
show "shows_monom_list m (r @ s) = shows_monom_list m r @ s"
by (induct m arbitrary: r s rule: shows_monom_list.induct, auto simp: show_law_simps)
qed
definition "shows_list (ts :: 'a monom list) = showsp_list shows_prec 0 ts"
instance by (standard, auto simp: show_law_simps shows_list_monom_def)
end
fun shows_poly :: "('v :: {show,linorder},'a :: {one,show})poly ⇒ string ⇒ string" where
"shows_poly [] = shows_string ''0''"
| "shows_poly ((m,c) # p) = ((if c = 1 then shows m else if m = 1 then shows c else shows c +@+
shows_string ''*'' +@+ shows m) +@+ (if p = [] then shows_string [] else shows_string '' + '' +@+ shows_poly p))"
end
Theory NZM
section ‹Monotonicity criteria of Neurauter, Zankl, and Middeldorp›
theory NZM
imports "Abstract-Rewriting.SN_Order_Carrier" Polynomials
begin
text ‹
We show that our check on monotonicity is strong enough to capture the
exact criterion for polynomials of degree 2 that is presented in \cite{NZM10}:
\begin{itemize}
\item $ax^2 + bx + c$ is monotone if $b + a > 0$ and $a \geq 0$
\item $ax^2 + bx + c$ is weakly monotone if $b + a \geq 0$ and $a \geq 0$
\end{itemize}
›
lemma var_monom_x_x [simp]: "var_monom x * var_monom x ≠ 1"
by (unfold eq_monom_sum_var, auto simp: sum_var_monom_mult sum_var_monom_var)
lemma monom_list_x_x[simp]: "monom_list (var_monom x * var_monom x) = [(x,2)]"
by (transfer, auto simp: monom_mult_list.simps)
lemma assumes b: "b + a > 0" and a: "(a :: int) ≥ 0"
shows "check_poly_strict_mono_discrete (>) (poly_of (PSum [PNum c, PMult [PNum b, PVar x], PMult [PNum a, PVar x, PVar x]])) x"
proof -
note [simp] = poly_add.simps poly_mult.simps monom_mult_poly.simps zero_poly_def one_poly_def
extract_def check_poly_strict_mono_discrete_def poly_subst.simps monom_subst_def poly_power.simps
check_poly_gt_def poly_split_def check_poly_ge.simps
show ?thesis
proof (cases "a = 0")
case True
with b have b: "b > 0 ∧ b ≠ 0" by auto
show ?thesis using b True by simp
next
case False
have [simp]: "2 = Suc (Suc 0)" by simp
show ?thesis using False a b by simp
qed
qed
lemma assumes b: "b + a ≥ 0" and a: "(a :: int) ≥ 0"
shows "check_poly_weak_mono_discrete (poly_of (PSum [PNum c, PMult [PNum b, PVar x], PMult [PNum a, PVar x, PVar x]])) x"
proof -
note [simp] = poly_add.simps poly_mult.simps monom_mult_poly.simps zero_poly_def one_poly_def
extract_def check_poly_weak_mono_discrete_def poly_subst.simps monom_subst_def poly_power.simps
check_poly_gt_def poly_split_def check_poly_ge.simps
show ?thesis
proof (cases "a = 0")
case True
with b have b: "0 ≤ b" by auto
show ?thesis using b True by simp
next
case False
have [simp]: "2 = Suc (Suc 0)" by simp
show ?thesis using False a b by simp
qed
qed
end